Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch pooryorick Excluding Merge-Ins
This is equivalent to a diff from 1df85e69fb to e3b25903c8
2022-01-05
| ||
12:27 | commit uncommited merge Leaf check-in: 1552422350 user: pooryorick tags: mime | |
2021-07-28
| ||
23:29 | Fix spelling error in mime.tcl. check-in: b8392d6ee9 user: pooryorick tags: trunk | |
23:28 | Merge trunk. Leaf check-in: e3b25903c8 user: pooryorick tags: pooryorick | |
22:50 | Merge trunk and fix smtp.tcl. check-in: db119d511f user: pooryorick tags: mime | |
18:54 | Fix goofy error handling in ::smtp::sendmessage. check-in: 1df85e69fb user: pooryorick tags: trunk | |
18:40 | Fix some small error in previous commit. check-in: 3d84236199 user: pooryorick tags: trunk | |
2021-04-30
| ||
12:12 | Merge trunk. check-in: e535000f3e user: pooryorick tags: pooryorick | |
Added embedded/www/tcllib/files/modules/clay/clay.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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 | <div class='fossil-doc' data-title='clay - Clay Framework'> <style> HTML { background: #FFFFFF; color: black; } BODY { background: #FFFFFF; color: black; } DIV.doctools { margin-left: 10%; margin-right: 10%; } DIV.doctools H1,DIV.doctools H2 { margin-left: -5%; } H1, H2, H3, H4 { margin-top: 1em; font-family: sans-serif; font-size: large; color: #005A9C; background: transparent; text-align: left; } H1.doctools_title { text-align: center; } UL,OL { margin-right: 0em; margin-top: 3pt; margin-bottom: 3pt; } UL LI { list-style: disc; } OL LI { list-style: decimal; } DT { padding-top: 1ex; } UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL { font: normal 12pt/14pt sans-serif; list-style: none; } LI.doctools_section, LI.doctools_subsection { list-style: none; margin-left: 0em; text-indent: 0em; padding: 0em; } PRE { display: block; font-family: monospace; white-space: pre; margin: 0%; padding-top: 0.5ex; padding-bottom: 0.5ex; padding-left: 1ex; padding-right: 1ex; width: 100%; } PRE.doctools_example { color: black; background: #f5dcb3; border: 1px solid black; } UL.doctools_requirements LI, UL.doctools_syntax LI { list-style: none; margin-left: 0em; text-indent: 0em; padding: 0em; } DIV.doctools_synopsis { color: black; background: #80ffff; border: 1px solid black; font-family: serif; margin-top: 1em; margin-bottom: 1em; } UL.doctools_syntax { margin-top: 1em; border-top: 1px solid black; } UL.doctools_requirements { margin-bottom: 1em; border-bottom: 1px solid black; } </style> <hr> [ <a href="../../../../toc.html">Main Table Of Contents</a> | <a href="../../../toc.html">Table Of Contents</a> | <a href="../../../../index.html">Keyword Index</a> | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">clay(n) 0.3 tcllib "Clay Framework"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> <p>clay - A minimalist framework for large scale OO Projects</p> </div> <div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2> <ul class="doctools_toc"> <li class="doctools_section"><a href="#toc">Table Of Contents</a></li> <li class="doctools_section"><a href="#synopsis">Synopsis</a></li> <li class="doctools_section"><a href="#section1">Description</a> <ul> <li class="doctools_subsection"><a href="#subsection1">Structured Data</a></li> <li class="doctools_subsection"><a href="#subsection2">Clay Dialect</a></li> <li class="doctools_subsection"><a href="#subsection3">Method Delegation</a></li> </ul> </li> <li class="doctools_section"><a href="#section2">Commands</a></li> <li class="doctools_section"><a href="#section3">Classes</a> <ul> <li class="doctools_subsection"><a href="#subsection4">Class oo::class</a></li> <li class="doctools_subsection"><a href="#subsection5">Class oo::object</a></li> <li class="doctools_subsection"><a href="#subsection6">Class clay::object</a></li> </ul> </li> <li class="doctools_section"><a href="#section4">AUTHORS</a></li> <li class="doctools_section"><a href="#section5">Bugs, Ideas, Feedback</a></li> <li class="doctools_section"><a href="#keywords">Keywords</a></li> <li class="doctools_section"><a href="#category">Category</a></li> <li class="doctools_section"><a href="#copyright">Copyright</a></li> </ul> </div> <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.6</b></li> <li>package require <b class="pkgname">uuid</b></li> <li>package require <b class="pkgname">oo::dialect</b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1">proc <b class="cmd">clay::ancestors</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#2">proc <b class="cmd">clay::args_to_dict</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#3">proc <b class="cmd">clay::args_to_options</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#4">proc <b class="cmd">clay::dynamic_arguments</b> <i class="arg">ensemble</i> <i class="arg">method</i> <i class="arg">arglist</i> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#5">proc <b class="cmd">clay::dynamic_wrongargs_message</b> <i class="arg">arglist</i></a></li> <li><a href="#6">proc <b class="cmd">clay::is_dict</b> <i class="arg">d</i></a></li> <li><a href="#7">proc <b class="cmd">clay::is_null</b> <i class="arg">value</i></a></li> <li><a href="#8">proc <b class="cmd">clay::leaf</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#9">proc <b class="cmd">clay::path</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#10">proc <b class="cmd">clay::script_path</b></a></li> <li><a href="#11">proc <b class="cmd">clay::NSNormalize</b> <i class="arg">qualname</i></a></li> <li><a href="#12">proc <b class="cmd">clay::uuid_generate</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#13">proc <b class="cmd">clay::dynamic_methods</b> <i class="arg">class</i></a></li> <li><a href="#14">proc <b class="cmd">clay::dynamic_methods_class</b> <i class="arg">thisclass</i></a></li> <li><a href="#15">proc <b class="cmd">clay::define::Array</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></li> <li><a href="#16">proc <b class="cmd">clay::define::component</b> <i class="arg">name</i> <i class="arg">info</i></a></li> <li><a href="#17">proc <b class="cmd">clay::define::constructor</b> <i class="arg">arglist</i> <i class="arg">rawbody</i></a></li> <li><a href="#18">proc <b class="cmd">clay::define::class_method</b> <i class="arg">name</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li> <li><a href="#19">proc <b class="cmd">clay::define::clay</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#20">proc <b class="cmd">clay::define::destructor</b> <i class="arg">rawbody</i></a></li> <li><a href="#21">proc <b class="cmd">clay::define::Dict</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></li> <li><a href="#22">proc <b class="cmd">clay::define::Variable</b> <i class="arg">name</i> <span class="opt">?<i class="arg">default</i> <b class="const"></b>?</span></a></li> <li><a href="#23">proc <b class="cmd">clay::object_create</b> <i class="arg">objname</i> <span class="opt">?<i class="arg">class</i> <b class="const"></b>?</span></a></li> <li><a href="#24">proc <b class="cmd">clay::object_rename</b> <i class="arg">object</i> <i class="arg">newname</i></a></li> <li><a href="#25">proc <b class="cmd">clay::object_destroy</b> <i class="arg">objname</i></a></li> <li><a href="#26">proc <b class="cmd">clay::ensemble_methodbody</b> <i class="arg">ensemble</i> <i class="arg">einfo</i></a></li> <li><a href="#27">proc <b class="cmd">clay::define::Ensemble</b> <i class="arg">rawmethod</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li> <li><a href="#28">method <b class="cmd">clay ancestors</b></a></li> <li><a href="#29">method <b class="cmd">clay dump</b></a></li> <li><a href="#30">method <b class="cmd">clay find</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#31">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#32">method <b class="cmd">clay GET</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#33">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></li> <li><a href="#34">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></li> <li><a href="#35">method <b class="cmd">clay search</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#36">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></li> <li><a href="#37">method <b class="cmd">clay ancestors</b></a></li> <li><a href="#38">method <b class="cmd">clay cget</b> <i class="arg">field</i></a></li> <li><a href="#39">method <b class="cmd">clay delegate</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">object</i>?</span></a></li> <li><a href="#40">method <b class="cmd">clay dump</b></a></li> <li><a href="#41">method <b class="cmd">clay ensemble_map</b></a></li> <li><a href="#42">method <b class="cmd">clay eval</b> <i class="arg">script</i></a></li> <li><a href="#43">method <b class="cmd">clay evolve</b></a></li> <li><a href="#44">method <b class="cmd">clay exists</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#45">method <b class="cmd">clay flush</b></a></li> <li><a href="#46">method <b class="cmd">clay forward</b> <i class="arg">method</i> <i class="arg">object</i></a></li> <li><a href="#47">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#48">method <b class="cmd">clay leaf</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#49">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></li> <li><a href="#50">method <b class="cmd">clay mixin</b> <i class="arg">class</i> <span class="opt">?<b class="option">class...</b>?</span></a></li> <li><a href="#51">method <b class="cmd">clay mixinmap</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">classes</i>?</span></a></li> <li><a href="#52">method <b class="cmd">clay provenance</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#53">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></li> <li><a href="#54">method <b class="cmd">clay source</b> <i class="arg">filename</i></a></li> <li><a href="#55">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></li> <li><a href="#56">method <b class="cmd">InitializePublic</b></a></li> <li><a href="#57">method <b class="cmd">InitializePublic</b></a></li> </ul> </div> </div> <div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2> <p>Clay introduces a method ensemble to both <b class="class">oo::class</b> and <b class="class">oo::object</b> called clay. This ensemble handles all of the high level interactions within the framework. Clay stores structured data. Clan manages method delegation. Clay has facilities to manage the complex interactions that come about with mixins.</p> <p>The central concept is that inside of every object and class (which are actually objects too) is a dict called clay. What is stored in that dict is left to the imagination. But because this dict is exposed via a public method, we can share structured data between object, classes, and mixins.</p> <div id="subsection1" class="doctools_subsection"><h3><a name="subsection1">Structured Data</a></h3> <p>Clay uses a standardized set of method interactions and introspection that TclOO already provides to perform on-the-fly searches. On-the-fly searches mean that the data is never stale, and we avoid many of the sorts of collisions that would arise when objects start mixing in other classes during operation.</p> <p>The <b class="method">clay</b> methods for both classes and objects have a get and a set method. For objects, get will search through the local clay dict. If the requested leaf is not found, or the query is for a branch, the system will then begin to poll the clay methods of all of the class that implements the object, all of that classes’ ancestors, as well as all of the classes that have been mixed into this object, and all of their ancestors.</p> <p>Intended branches on a tree end with a directory slash (/). Intended leaves are left unadorned. This is a guide for the tool that builds the search results to know what parts of a dict are intended to be branches and which are intended to be leaves. For simple cases, branch marking can be ignored:</p> <pre class="doctools_example"> ::oo::class create ::foo { } ::foo clay set property/ color blue ::foo clay set property/ shape round set A [::foo new] $A clay get property/ {color blue shape round} $A clay set property/ shape square $A clay get property/ {color blue shape square} </pre> <p>But when you start storing blocks of text, guessing what field is a dict and what isn’t gets messy:</p> <pre class="doctools_example"> ::foo clay set description {A generic thing of designated color and shape} $A clay get description {A generic thing of designated color and shape} Without a convention for discerning branches for leaves what should have been a value can be accidentally parsed as a dictionary, and merged with all of the other values that were never intended to be merge. Here is an example of it all going wrong: ::oo::class create ::foo { } # Add description as a leaf ::foo clay set description {A generic thing of designated color and shape} # Add description as a branch ::foo clay set description/ {A generic thing of designated color and shape} ::oo::class create ::bar { superclass foo } # Add description as a leaf ::bar clay set description {A drinking establishment of designated color and shape and size} # Add description as a branch ::bar clay set description/ {A drinking establishment of designated color and shape and size} set B [::bar new] # As a leaf we get the value verbatim from he nearest ancestor $B clay get description {A drinking establishment of designated color and shape and size} # As a branch we get a recursive merge $B clay get description/ {A drinking establishment of designated color and size thing of} </pre> </div> <div id="subsection2" class="doctools_subsection"><h3><a name="subsection2">Clay Dialect</a></h3> <p>Clay is built using the oo::dialect module from Tcllib. oo::dialect allows you to either add keywords directly to clay, or to create your own metaclass and keyword set using Clay as a foundation. For details on the keywords and what they do, consult the functions in the ::clay::define namespace.</p> </div> <div id="subsection3" class="doctools_subsection"><h3><a name="subsection3">Method Delegation</a></h3> <p>Method Delegation It is sometimes useful to have an external object that can be invoked as if it were a method of the object. Clay provides a delegate ensemble method to perform that delegation, as well as introspect which methods are delegated in that manner. All delegated methods are marked with html-like tag markings (< >) around them.</p> <pre class="doctools_example"> ::clay::define counter { Variable counter 0 method incr {{howmuch 1}} { my variable counter incr counter $howmuch } method value {} { my variable counter return $counter } method reset {} { my variable counter set counter 0 } } ::clay::define example { variable buffer constructor {} { # Build a counter object set obj [namespace current]::counter ::counter create $obj # Delegate the counter my delegate <counter> $obj } method line {text} { my <counter> incr append buffer $text } } set A [example new] $A line {Who’s line is it anyway?} $A <counter> value 1 </pre> </div> </div> <div id="section2" class="doctools_section"><h2><a name="section2">Commands</a></h2> <dl class="doctools_definitions"> <dt><a name="1">proc <b class="cmd">clay::ancestors</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="2">proc <b class="cmd">clay::args_to_dict</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="3">proc <b class="cmd">clay::args_to_options</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="4">proc <b class="cmd">clay::dynamic_arguments</b> <i class="arg">ensemble</i> <i class="arg">method</i> <i class="arg">arglist</i> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="5">proc <b class="cmd">clay::dynamic_wrongargs_message</b> <i class="arg">arglist</i></a></dt> <dd></dd> <dt><a name="6">proc <b class="cmd">clay::is_dict</b> <i class="arg">d</i></a></dt> <dd></dd> <dt><a name="7">proc <b class="cmd">clay::is_null</b> <i class="arg">value</i></a></dt> <dd></dd> <dt><a name="8">proc <b class="cmd">clay::leaf</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="9">proc <b class="cmd">clay::path</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="10">proc <b class="cmd">clay::script_path</b></a></dt> <dd></dd> <dt><a name="11">proc <b class="cmd">clay::NSNormalize</b> <i class="arg">qualname</i></a></dt> <dd></dd> <dt><a name="12">proc <b class="cmd">clay::uuid_generate</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="13">proc <b class="cmd">clay::dynamic_methods</b> <i class="arg">class</i></a></dt> <dd></dd> <dt><a name="14">proc <b class="cmd">clay::dynamic_methods_class</b> <i class="arg">thisclass</i></a></dt> <dd></dd> <dt><a name="15">proc <b class="cmd">clay::define::Array</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></dt> <dd><p>New OO Keywords for clay</p></dd> <dt><a name="16">proc <b class="cmd">clay::define::component</b> <i class="arg">name</i> <i class="arg">info</i></a></dt> <dd></dd> <dt><a name="17">proc <b class="cmd">clay::define::constructor</b> <i class="arg">arglist</i> <i class="arg">rawbody</i></a></dt> <dd></dd> <dt><a name="18">proc <b class="cmd">clay::define::class_method</b> <i class="arg">name</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt> <dd></dd> <dt><a name="19">proc <b class="cmd">clay::define::clay</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="20">proc <b class="cmd">clay::define::destructor</b> <i class="arg">rawbody</i></a></dt> <dd></dd> <dt><a name="21">proc <b class="cmd">clay::define::Dict</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></dt> <dd></dd> <dt><a name="22">proc <b class="cmd">clay::define::Variable</b> <i class="arg">name</i> <span class="opt">?<i class="arg">default</i> <b class="const"></b>?</span></a></dt> <dd><p>This keyword can also be expressed:</p> <pre class="doctools_example">property variable NAME {default DEFAULT}</pre> <p>Variables registered in the variable property are also initialized (if missing) when the object changes class via the <em>morph</em> method.</p></dd> <dt><a name="23">proc <b class="cmd">clay::object_create</b> <i class="arg">objname</i> <span class="opt">?<i class="arg">class</i> <b class="const"></b>?</span></a></dt> <dd></dd> <dt><a name="24">proc <b class="cmd">clay::object_rename</b> <i class="arg">object</i> <i class="arg">newname</i></a></dt> <dd></dd> <dt><a name="25">proc <b class="cmd">clay::object_destroy</b> <i class="arg">objname</i></a></dt> <dd></dd> <dt><a name="26">proc <b class="cmd">clay::ensemble_methodbody</b> <i class="arg">ensemble</i> <i class="arg">einfo</i></a></dt> <dd></dd> <dt><a name="27">proc <b class="cmd">clay::define::Ensemble</b> <i class="arg">rawmethod</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt> <dd></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">Classes</a></h2> <div id="subsection4" class="doctools_subsection"><h3><a name="subsection4">Class oo::class</a></h3> <p><b class="class">Methods</b></p> <dl class="doctools_definitions"> <dt><a name="28">method <b class="cmd">clay ancestors</b></a></dt> <dd><p>Return this class and all ancestors in search order.</p></dd> <dt><a name="29">method <b class="cmd">clay dump</b></a></dt> <dd><p>Return a complete dump of this object's clay data, but only this object's clay data.</p></dd> <dt><a name="30">method <b class="cmd">clay find</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the clay system. If the last element of <em>path</em> is a branch, returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching leaf and return the first value found. If no value is found, returns an empty string. If a branch is returned the topmost . entry is omitted.</p></dd> <dt><a name="31">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the class's clay system. If no value is found, returns an empty string. If a branch is returned the topmost . entry is omitted.</p></dd> <dt><a name="32">method <b class="cmd">clay GET</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the class's clay system. If no value is found, returns an empty string.</p></dd> <dt><a name="33">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></dt> <dd><p>Recursively merge the dictionaries given into the object's local clay storage.</p></dd> <dt><a name="34">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></dt> <dd><p>Replace the contents of the internal clay storage with the dictionary given.</p></dd> <dt><a name="35">method <b class="cmd">clay search</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Return the first matching value for the path in either this class's clay data or one of its ancestors</p></dd> <dt><a name="36">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></dt> <dd><p>Merge the conents of <b class="const">value</b> with the object's clay storage at <b class="const">path</b>.</p></dd> </dl> </div> <div id="subsection5" class="doctools_subsection"><h3><a name="subsection5">Class oo::object</a></h3> <p><b class="class">Methods</b></p> <dl class="doctools_definitions"> <dt><a name="37">method <b class="cmd">clay ancestors</b></a></dt> <dd><p>Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.</p></dd> <dt><a name="38">method <b class="cmd">clay cget</b> <i class="arg">field</i></a></dt> <dd><p>Pull a value from either the object's clay structure or one of its constituent classes that matches the field name. The order of search us:</p> <p>1. The as a value in local dict variable config</p> <p>2. The as a value in local dict variable clay</p> <p>3. As a leaf in any ancestor as a root of the clay tree</p> <p>4. As a leaf in any ancestor as <b class="const">const</b> <em>field</em></p> <p>5. As a leaf in any ancestor as <b class="const">option</b> <em>field</em> <b class="const">default</b></p></dd> <dt><a name="39">method <b class="cmd">clay delegate</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">object</i>?</span></a></dt> <dd><p>Introspect or control method delegation. With no arguments, the method will return a key/value list of stubs and objects. With just the <i class="arg">stub</i> argument, the method will return the object (if any) attached to the stub. With a <i class="arg">stub</i> and an <i class="arg">object</i> this command will forward all calls to the method <i class="arg">stub</i> to the <i class="arg">object</i>.</p></dd> <dt><a name="40">method <b class="cmd">clay dump</b></a></dt> <dd><p>Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in.</p></dd> <dt><a name="41">method <b class="cmd">clay ensemble_map</b></a></dt> <dd><p>Return a dictionary describing the method ensembles to be assembled for this object</p></dd> <dt><a name="42">method <b class="cmd">clay eval</b> <i class="arg">script</i></a></dt> <dd><p>Evaluated a script in the namespace of this object</p></dd> <dt><a name="43">method <b class="cmd">clay evolve</b></a></dt> <dd><p>Trigger the <b class="method">InitializePublic</b> private method</p></dd> <dt><a name="44">method <b class="cmd">clay exists</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Returns 1 if <em>path</em> exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found.</p></dd> <dt><a name="45">method <b class="cmd">clay flush</b></a></dt> <dd><p>Wipe any caches built by the clay implementation</p></dd> <dt><a name="46">method <b class="cmd">clay forward</b> <i class="arg">method</i> <i class="arg">object</i></a></dt> <dd><p>A convenience wrapper for</p> <pre class="doctools_example">oo::objdefine [self] forward {*}$args</pre> </dd> <dt><a name="47">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the clay system. If the last element of <em>path</em> is a branch (ends in a slash /), returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching leaf and return the first value found. If no value is found, returns an empty string.</p></dd> <dt><a name="48">method <b class="cmd">clay leaf</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>A modified get which is tailored to pull only leaf elements</p></dd> <dt><a name="49">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></dt> <dd><p>Recursively merge the dictionaries given into the object's local clay storage.</p></dd> <dt><a name="50">method <b class="cmd">clay mixin</b> <i class="arg">class</i> <span class="opt">?<b class="option">class...</b>?</span></a></dt> <dd><p>Perform [oo::objdefine [self] mixin] on this object, with a few additional rules: Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.) For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.) Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.)</p></dd> <dt><a name="51">method <b class="cmd">clay mixinmap</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">classes</i>?</span></a></dt> <dd><p>With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given, returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given classes and invoke clay mixin on the new matrix of mixed in classes.</p></dd> <dt><a name="52">method <b class="cmd">clay provenance</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Return either <b class="const">self</b> if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element.</p></dd> <dt><a name="53">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></dt> <dd><p>Replace the contents of the internal clay storage with the dictionary given.</p></dd> <dt><a name="54">method <b class="cmd">clay source</b> <i class="arg">filename</i></a></dt> <dd><p>Source the given filename within the object's namespace</p></dd> <dt><a name="55">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></dt> <dd><p>Merge the conents of <b class="const">value</b> with the object's clay storage at <b class="const">path</b>.</p></dd> <dt><a name="56">method <b class="cmd">InitializePublic</b></a></dt> <dd><p>Instantiate variables. Called on object creation and during clay mixin.</p></dd> </dl> </div> <div id="subsection6" class="doctools_subsection"><h3><a name="subsection6">Class clay::object</a></h3> <p>clay::object This class is inherited by all classes that have options.</p> <p><b class="class">Methods</b></p> <dl class="doctools_definitions"> <dt><a name="57">method <b class="cmd">InitializePublic</b></a></dt> <dd><p>Instantiate variables and build ensemble methods.</p></dd> </dl> </div> </div> <div id="section4" class="doctools_section"><h2><a name="section4">AUTHORS</a></h2> <p>Sean Woods <a href="mailto:<[email protected]>">mailto:<[email protected]></a></p> </div> <div id="section5" class="doctools_section"><h2><a name="section5">Bugs, Ideas, Feedback</a></h2> <p>This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category <em>oo</em> of the <a href="http://core.tcl.tk/tcllib/reportlist">Tcllib Trackers</a>. Please also report any ideas for enhancements you may have for either package and/or documentation.</p> <p>When proposing code changes, please provide <em>unified diffs</em>, i.e the output of <b class="const">diff -u</b>.</p> <p>Note further that <em>attachments</em> are strongly preferred over inlined patches. Attachments can be made by going to the <b class="const">Edit</b> form of the ticket immediately after its creation, and then using the left-most button in the secondary navigation bar.</p> </div> <div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2> <p><a href="../../../../index.html#tcloo">TclOO</a>, <a href="../../../../index.html#oo">oo</a></p> </div> <div id="category" class="doctools_section"><h2><a name="category">Category</a></h2> <p>Programming tools</p> </div> <div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2> <p>Copyright © 2018 Sean Woods <[email protected]></p> </div> </div> |
Added embedded/www/tcllib/files/modules/math/trig.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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 | <div class='fossil-doc' data-title='math::trig - Tcl Math Library'> <style> HTML { background: #FFFFFF; color: black; } BODY { background: #FFFFFF; color: black; } DIV.doctools { margin-left: 10%; margin-right: 10%; } DIV.doctools H1,DIV.doctools H2 { margin-left: -5%; } H1, H2, H3, H4 { margin-top: 1em; font-family: sans-serif; font-size: large; color: #005A9C; background: transparent; text-align: left; } H1.doctools_title { text-align: center; } UL,OL { margin-right: 0em; margin-top: 3pt; margin-bottom: 3pt; } UL LI { list-style: disc; } OL LI { list-style: decimal; } DT { padding-top: 1ex; } UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL { font: normal 12pt/14pt sans-serif; list-style: none; } LI.doctools_section, LI.doctools_subsection { list-style: none; margin-left: 0em; text-indent: 0em; padding: 0em; } PRE { display: block; font-family: monospace; white-space: pre; margin: 0%; padding-top: 0.5ex; padding-bottom: 0.5ex; padding-left: 1ex; padding-right: 1ex; width: 100%; } PRE.doctools_example { color: black; background: #f5dcb3; border: 1px solid black; } UL.doctools_requirements LI, UL.doctools_syntax LI { list-style: none; margin-left: 0em; text-indent: 0em; padding: 0em; } DIV.doctools_synopsis { color: black; background: #80ffff; border: 1px solid black; font-family: serif; margin-top: 1em; margin-bottom: 1em; } UL.doctools_syntax { margin-top: 1em; border-top: 1px solid black; } UL.doctools_requirements { margin-bottom: 1em; border-bottom: 1px solid black; } </style> <hr> [ <a href="../../../../toc.html">Main Table Of Contents</a> | <a href="../../../toc.html">Table Of Contents</a> | <a href="../../../../index.html">Keyword Index</a> | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">math::trig(n) 1.0.0 tcllib "Tcl Math Library"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> <p>math::trig - Trigonometric anf hyperbolic functions</p> </div> <div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2> <ul class="doctools_toc"> <li class="doctools_section"><a href="#toc">Table Of Contents</a></li> <li class="doctools_section"><a href="#synopsis">Synopsis</a></li> <li class="doctools_section"><a href="#section1">Description</a></li> <li class="doctools_section"><a href="#section2">FUNCTIONS</a></li> <li class="doctools_section"><a href="#section3">Bugs, Ideas, Feedback</a></li> <li class="doctools_section"><a href="#keywords">Keywords</a></li> <li class="doctools_section"><a href="#category">Category</a></li> <li class="doctools_section"><a href="#copyright">Copyright</a></li> </ul> </div> <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.5</b></li> <li>package require <b class="pkgname">math::trig 1.0.0</b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1"><b class="cmd">::math::trig::radian_reduced</b> <i class="arg">angle</i></a></li> <li><a href="#2"><b class="cmd">::math::trig::degree_reduced</b> <i class="arg">angle</i></a></li> <li><a href="#3"><b class="cmd">::math::trig::cosec</b> <i class="arg">angle</i></a></li> <li><a href="#4"><b class="cmd">::math::trig::sec</b> <i class="arg">angle</i></a></li> <li><a href="#5"><b class="cmd">::math::trig::cotan</b> <i class="arg">angle</i></a></li> <li><a href="#6"><b class="cmd">::math::trig::acosec</b> <i class="arg">value</i></a></li> <li><a href="#7"><b class="cmd">::math::trig::asec</b> <i class="arg">value</i></a></li> <li><a href="#8"><b class="cmd">::math::trig::acotan</b> <i class="arg">value</i></a></li> <li><a href="#9"><b class="cmd">::math::trig::cosech</b> <i class="arg">value</i></a></li> <li><a href="#10"><b class="cmd">::math::trig::sech</b> <i class="arg">value</i></a></li> <li><a href="#11"><b class="cmd">::math::trig::cotanh</b> <i class="arg">value</i></a></li> <li><a href="#12"><b class="cmd">::math::trig::asinh</b> <i class="arg">value</i></a></li> <li><a href="#13"><b class="cmd">::math::trig::acosh</b> <i class="arg">value</i></a></li> <li><a href="#14"><b class="cmd">::math::trig::atanh</b> <i class="arg">value</i></a></li> <li><a href="#15"><b class="cmd">::math::trig::acosech</b> <i class="arg">value</i></a></li> <li><a href="#16"><b class="cmd">::math::trig::asech</b> <i class="arg">value</i></a></li> <li><a href="#17"><b class="cmd">::math::trig::acotanh</b> <i class="arg">value</i></a></li> <li><a href="#18"><b class="cmd">::math::trig::sind</b> <i class="arg">angle</i></a></li> <li><a href="#19"><b class="cmd">::math::trig::cosd</b> <i class="arg">angle</i></a></li> <li><a href="#20"><b class="cmd">::math::trig::tand</b> <i class="arg">angle</i></a></li> <li><a href="#21"><b class="cmd">::math::trig::cosecd</b> <i class="arg">angle</i></a></li> <li><a href="#22"><b class="cmd">::math::trig::secd</b> <i class="arg">angle</i></a></li> <li><a href="#23"><b class="cmd">::math::trig::cotand</b> <i class="arg">angle</i></a></li> </ul> </div> </div> <div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2> <p>The <i class="term">math::trig</i> package defines a set of trigonomic and hyperbolic functions and their inverses. In addition it defines versions of the trigonomic functions that take arguments in degrees instead of radians.</p> <p>For easy use these functions may be imported into the <i class="term">tcl::mathfunc</i> namespace, so that they can be used directly in the <i class="term">expr</i> command.</p> </div> <div id="section2" class="doctools_section"><h2><a name="section2">FUNCTIONS</a></h2> <p>The functions <i class="term">radian_reduced</i> and <i class="term">degree_reduced</i> return a reduced angle, in respectively radians and degrees, in the intervals [0, 2pi) and [0, 360):</p> <dl class="doctools_definitions"> <dt><a name="1"><b class="cmd">::math::trig::radian_reduced</b> <i class="arg">angle</i></a></dt> <dd><p>Return the equivalent angle in the interval [0, 2pi).</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in radians)</p></dd> </dl></dd> <dt><a name="2"><b class="cmd">::math::trig::degree_reduced</b> <i class="arg">angle</i></a></dt> <dd><p>Return the equivalent angle in the interval [0, 360).</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in degrees)</p></dd> </dl></dd> </dl> <p>The following trigonomic functions are defined in addition to the ones defined in the <i class="term">expr</i> command:</p> <dl class="doctools_definitions"> <dt><a name="3"><b class="cmd">::math::trig::cosec</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the cosecant of the angle (1/cos(angle))</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in radians)</p></dd> </dl></dd> <dt><a name="4"><b class="cmd">::math::trig::sec</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the secant of the angle (1/sin(angle))</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in radians)</p></dd> </dl></dd> <dt><a name="5"><b class="cmd">::math::trig::cotan</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the cotangent of the angle (1/tan(angle))</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in radians)</p></dd> </dl></dd> </dl> <p>For these functions also the inverses are defined:</p> <dl class="doctools_definitions"> <dt><a name="6"><b class="cmd">::math::trig::acosec</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc cosecant of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="7"><b class="cmd">::math::trig::asec</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc secant of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="8"><b class="cmd">::math::trig::acotan</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc cotangent of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> </dl> <p>The following hyperbolic and inverse hyperbolic functions are defined:</p> <dl class="doctools_definitions"> <dt><a name="9"><b class="cmd">::math::trig::cosech</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the hyperbolic cosecant of the value (1/sinh(value))</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="10"><b class="cmd">::math::trig::sech</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the hyperbolic secant of the value (1/cosh(value))</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="11"><b class="cmd">::math::trig::cotanh</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the hyperbolic cotangent of the value (1/tanh(value))</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="12"><b class="cmd">::math::trig::asinh</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc hyperbolic sine of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="13"><b class="cmd">::math::trig::acosh</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc hyperbolic cosine of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="14"><b class="cmd">::math::trig::atanh</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc hyperbolic tangent of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="15"><b class="cmd">::math::trig::acosech</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc hyperbolic cosecant of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="16"><b class="cmd">::math::trig::asech</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc hyperbolic secant of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> <dt><a name="17"><b class="cmd">::math::trig::acotanh</b> <i class="arg">value</i></a></dt> <dd><p>Calculate the arc hyperbolic cotangent of the value</p> <dl class="doctools_arguments"> <dt>float <i class="arg">value</i></dt> <dd><p>Value of the argument</p></dd> </dl></dd> </dl> <p>The following versions of the common trigonometric functions and their inverses are defined:</p> <dl class="doctools_definitions"> <dt><a name="18"><b class="cmd">::math::trig::sind</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the sine of the angle (in degrees)</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in degrees)</p></dd> </dl></dd> <dt><a name="19"><b class="cmd">::math::trig::cosd</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the cosine of the angle (in degrees)</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in radians)</p></dd> </dl></dd> <dt><a name="20"><b class="cmd">::math::trig::tand</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the cotangent of the angle (in degrees)</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in degrees)</p></dd> </dl></dd> <dt><a name="21"><b class="cmd">::math::trig::cosecd</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the cosecant of the angle (in degrees)</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in degrees)</p></dd> </dl></dd> <dt><a name="22"><b class="cmd">::math::trig::secd</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the secant of the angle (in degrees)</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in degrees)</p></dd> </dl></dd> <dt><a name="23"><b class="cmd">::math::trig::cotand</b> <i class="arg">angle</i></a></dt> <dd><p>Calculate the cotangent of the angle (in degrees)</p> <dl class="doctools_arguments"> <dt>float <i class="arg">angle</i></dt> <dd><p>Angle (in degrees)</p></dd> </dl></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">Bugs, Ideas, Feedback</a></h2> <p>This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category <em>math :: trig</em> of the <a href="http://core.tcl.tk/tcllib/reportlist">Tcllib Trackers</a>. Please also report any ideas for enhancements you may have for either package and/or documentation.</p> <p>When proposing code changes, please provide <em>unified diffs</em>, i.e the output of <b class="const">diff -u</b>.</p> <p>Note further that <em>attachments</em> are strongly preferred over inlined patches. Attachments can be made by going to the <b class="const">Edit</b> form of the ticket immediately after its creation, and then using the left-most button in the secondary navigation bar.</p> </div> <div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2> <p><a href="../../../../index.html#math">math</a>, <a href="../../../../index.html#trigonometry">trigonometry</a></p> </div> <div id="category" class="doctools_section"><h2><a name="category">Category</a></h2> <p>Mathematics</p> </div> <div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2> <p>Copyright © 2018 Arjen Markus</p> </div> </div> |
Added examples/httpd/htdocs/html_static_page.html.
> > > > > | 1 2 3 4 5 | <html><header><title>Static Content</title></header> <body> <h1>Static Content</h1> This page is static content embedded in the file system. Nothing fancy. </body></html> |
Changes to idoc/man/files/modules/clay/clay.n.
1 2 3 4 | '\" '\" Generated from file 'clay\&.man' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2018 Sean Woods <yoda@etoyoc\&.com> '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Generated from file 'clay\&.man' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2018 Sean Woods <yoda@etoyoc\&.com> '\" .TH "clay" n 0\&.3 tcllib "Clay Framework" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. .\" type is type of argument (int, etc.), in/out is either "in", "out", .\" or "in/out" to describe whether procedure reads or modifies arg, |
︙ | ︙ | |||
276 277 278 279 280 281 282 | .SH SYNOPSIS package require \fBTcl 8\&.6\fR .sp package require \fBuuid \fR .sp package require \fBoo::dialect \fR .sp | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | | | | | < < < < < < < < < < < < < < < < < < < < | 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 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 | .SH SYNOPSIS package require \fBTcl 8\&.6\fR .sp package require \fBuuid \fR .sp package require \fBoo::dialect \fR .sp proc \fBclay::ancestors\fR ?\fIargs\fR? .sp proc \fBclay::args_to_dict\fR ?\fIargs\fR? .sp proc \fBclay::args_to_options\fR ?\fIargs\fR? .sp proc \fBclay::dynamic_arguments\fR \fIensemble\fR \fImethod\fR \fIarglist\fR ?\fIargs\fR? .sp proc \fBclay::dynamic_wrongargs_message\fR \fIarglist\fR .sp proc \fBclay::is_dict\fR \fId\fR .sp proc \fBclay::is_null\fR \fIvalue\fR .sp proc \fBclay::leaf\fR ?\fIargs\fR? .sp proc \fBclay::path\fR ?\fIargs\fR? .sp proc \fBclay::script_path\fR .sp proc \fBclay::NSNormalize\fR \fIqualname\fR .sp proc \fBclay::uuid_generate\fR ?\fIargs\fR? .sp proc \fBclay::dynamic_methods\fR \fIclass\fR .sp proc \fBclay::dynamic_methods_class\fR \fIthisclass\fR .sp proc \fBclay::define::Array\fR \fIname\fR ?\fIvalues\fR \fB\fR? .sp proc \fBclay::define::component\fR \fIname\fR \fIinfo\fR .sp proc \fBclay::define::constructor\fR \fIarglist\fR \fIrawbody\fR .sp proc \fBclay::define::class_method\fR \fIname\fR \fIarglist\fR \fIbody\fR .sp proc \fBclay::define::clay\fR ?\fIargs\fR? .sp proc \fBclay::define::destructor\fR \fIrawbody\fR .sp proc \fBclay::define::Dict\fR \fIname\fR ?\fIvalues\fR \fB\fR? .sp proc \fBclay::define::Variable\fR \fIname\fR ?\fIdefault\fR \fB\fR? .sp proc \fBclay::object_create\fR \fIobjname\fR ?\fIclass\fR \fB\fR? .sp proc \fBclay::object_rename\fR \fIobject\fR \fInewname\fR .sp proc \fBclay::object_destroy\fR \fIobjname\fR .sp proc \fBclay::ensemble_methodbody\fR \fIensemble\fR \fIeinfo\fR .sp proc \fBclay::define::Ensemble\fR \fIrawmethod\fR \fIarglist\fR \fIbody\fR .sp method \fBclay ancestors\fR .sp method \fBclay dump\fR .sp method \fBclay find\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? .sp |
︙ | ︙ | |||
436 437 438 439 440 441 442 | .sp method \fBclay search\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? .sp method \fBclay set\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? \fIvalue\fR .sp method \fBclay ancestors\fR .sp | < < | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 | .sp method \fBclay search\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? .sp method \fBclay set\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? \fIvalue\fR .sp method \fBclay ancestors\fR .sp method \fBclay cget\fR \fIfield\fR .sp method \fBclay delegate\fR ?\fIstub\fR? ?\fIobject\fR? .sp method \fBclay dump\fR .sp method \fBclay ensemble_map\fR |
︙ | ︙ | |||
470 471 472 473 474 475 476 | .sp method \fBclay mixinmap\fR ?\fIstub\fR? ?\fIclasses\fR? .sp method \fBclay provenance\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? .sp method \fBclay replace\fR \fIdictionary\fR .sp | < < > > | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | .sp method \fBclay mixinmap\fR ?\fIstub\fR? ?\fIclasses\fR? .sp method \fBclay provenance\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? .sp method \fBclay replace\fR \fIdictionary\fR .sp method \fBclay source\fR \fIfilename\fR .sp method \fBclay set\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? \fIvalue\fR .sp method \fBInitializePublic\fR .sp method \fBInitializePublic\fR .sp .BE .SH DESCRIPTION Clay introduces a method ensemble to both \fBoo::class\fR and \fBoo::object\fR called clay\&. This ensemble handles all of the high level interactions within the framework\&. |
︙ | ︙ | |||
595 596 597 598 599 600 601 | $A line {Who’s line is it anyway?} $A <counter> value 1 .CE .SH COMMANDS .TP | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < | < | < | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 | $A line {Who’s line is it anyway?} $A <counter> value 1 .CE .SH COMMANDS .TP proc \fBclay::ancestors\fR ?\fIargs\fR? .TP proc \fBclay::args_to_dict\fR ?\fIargs\fR? .TP proc \fBclay::args_to_options\fR ?\fIargs\fR? .TP proc \fBclay::dynamic_arguments\fR \fIensemble\fR \fImethod\fR \fIarglist\fR ?\fIargs\fR? .TP proc \fBclay::dynamic_wrongargs_message\fR \fIarglist\fR .TP proc \fBclay::is_dict\fR \fId\fR .TP proc \fBclay::is_null\fR \fIvalue\fR .TP proc \fBclay::leaf\fR ?\fIargs\fR? .TP proc \fBclay::path\fR ?\fIargs\fR? .TP proc \fBclay::script_path\fR .TP proc \fBclay::NSNormalize\fR \fIqualname\fR .TP proc \fBclay::uuid_generate\fR ?\fIargs\fR? .TP proc \fBclay::dynamic_methods\fR \fIclass\fR .TP proc \fBclay::dynamic_methods_class\fR \fIthisclass\fR .TP proc \fBclay::define::Array\fR \fIname\fR ?\fIvalues\fR \fB\fR? New OO Keywords for clay .TP proc \fBclay::define::component\fR \fIname\fR \fIinfo\fR .TP proc \fBclay::define::constructor\fR \fIarglist\fR \fIrawbody\fR .TP proc \fBclay::define::class_method\fR \fIname\fR \fIarglist\fR \fIbody\fR .TP proc \fBclay::define::clay\fR ?\fIargs\fR? .TP proc \fBclay::define::destructor\fR \fIrawbody\fR .TP proc \fBclay::define::Dict\fR \fIname\fR ?\fIvalues\fR \fB\fR? .TP proc \fBclay::define::Variable\fR \fIname\fR ?\fIdefault\fR \fB\fR? This keyword can also be expressed: .CS property variable NAME {default DEFAULT} .CE .sp Variables registered in the variable property are also initialized (if missing) when the object changes class via the \fImorph\fR method\&. .TP proc \fBclay::object_create\fR \fIobjname\fR ?\fIclass\fR \fB\fR? .TP proc \fBclay::object_rename\fR \fIobject\fR \fInewname\fR .TP proc \fBclay::object_destroy\fR \fIobjname\fR .TP proc \fBclay::ensemble_methodbody\fR \fIensemble\fR \fIeinfo\fR .TP proc \fBclay::define::Ensemble\fR \fIrawmethod\fR \fIarglist\fR \fIbody\fR .PP .SH CLASSES .SS "CLASS OO::CLASS" .PP \fBMethods\fR .TP method \fBclay ancestors\fR Return this class and all ancestors in search order\&. .TP method \fBclay dump\fR |
︙ | ︙ | |||
938 939 940 941 942 943 944 | method \fBclay search\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? Return the first matching value for the path in either this class's clay data or one of its ancestors .TP method \fBclay set\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? \fIvalue\fR Merge the conents of \fBvalue\fR with the object's clay storage at \fBpath\fR\&. .PP .PP | | < < < < < | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | method \fBclay search\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? Return the first matching value for the path in either this class's clay data or one of its ancestors .TP method \fBclay set\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? \fIvalue\fR Merge the conents of \fBvalue\fR with the object's clay storage at \fBpath\fR\&. .PP .PP .SS "CLASS OO::OBJECT" .PP \fBMethods\fR .TP method \fBclay ancestors\fR Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order\&. .TP method \fBclay cget\fR \fIfield\fR Pull a value from either the object's clay structure or one of its constituent classes that matches the field name\&. The order of search us: .sp 1\&. The as a value in local dict variable config .sp 2\&. The as a value in local dict variable clay |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 | .TP method \fBclay provenance\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? Return either \fBself\fR if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element\&. .TP method \fBclay replace\fR \fIdictionary\fR Replace the contents of the internal clay storage with the dictionary given\&. .TP | < < < > > > > > > > > > > | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 | .TP method \fBclay provenance\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? Return either \fBself\fR if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element\&. .TP method \fBclay replace\fR \fIdictionary\fR Replace the contents of the internal clay storage with the dictionary given\&. .TP method \fBclay source\fR \fIfilename\fR Source the given filename within the object's namespace .TP method \fBclay set\fR \fIpath\fR ?\fBpath\&.\&.\&.\fR? \fIvalue\fR Merge the conents of \fBvalue\fR with the object's clay storage at \fBpath\fR\&. .TP method \fBInitializePublic\fR Instantiate variables\&. Called on object creation and during clay mixin\&. .PP .PP .SS "CLASS CLAY::OBJECT" clay::object This class is inherited by all classes that have options\&. .PP \fBMethods\fR .TP method \fBInitializePublic\fR Instantiate variables and build ensemble methods\&. .PP .PP .SH AUTHORS Sean Woods \fImailto:<yoda@etoyoc\&.com>\fR .PP .SH "BUGS, IDEAS, FEEDBACK" This document, and the package it describes, will undoubtedly contain bugs and other problems\&. |
︙ | ︙ |
Changes to idoc/man/files/modules/cron/cron.n.
︙ | ︙ |
Changes to idoc/man/files/modules/dicttool/dicttool.n.
1 2 | '\" '\" Generated from file 'dicttool\&.man' by tcllib/doctools with format 'nroff' | | | | 1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Generated from file 'dicttool\&.man' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2018 Sean Woods <yoda@etoyoc\&.com> '\" .TH "dicttool" n 1\&.2 tcllib "Extensions to the standard "dict" command" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. .\" type is type of argument (int, etc.), in/out is either "in", "out", .\" or "in/out" to describe whether procedure reads or modifies arg, |
︙ | ︙ | |||
293 294 295 296 297 298 299 300 | .BE .SH DESCRIPTION .PP The \fBdicttool\fR package enhances the standard \fIdict\fR command with several new commands\&. In addition, the package also defines several "creature comfort" list commands as well\&. Each command checks to see if a command already exists of the same name before adding itself, just in case any of these slip into the core\&. .TP | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | < | < < < < < < < < < < > > > > > > < < < < < < < < | > > | > > | | | | | < < < | | < > > > > > > | 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 | .BE .SH DESCRIPTION .PP The \fBdicttool\fR package enhances the standard \fIdict\fR command with several new commands\&. In addition, the package also defines several "creature comfort" list commands as well\&. Each command checks to see if a command already exists of the same name before adding itself, just in case any of these slip into the core\&. .SH COMMANDS .TP proc \fBPROC\fR \fIname\fR \fIarglist\fR \fIbody\fR ?\fIninja\fR \fB\fR? Because many features in this package may be added as commands to future tcl cores, or be provided in binary form by packages, I need a declaritive way of saying \fICreate this command if there isn't one already\fR\&. The \fIninja\fR argument is a script to execute if the command is created by this mechanism\&. .TP proc \fBnoop\fR ?\fIargs\fR? Perform a noop\&. Useful in prototyping for commenting out blocks of code without actually having to comment them out\&. It also makes a handy default for method delegation if a delegate has not been assigned yet\&. .TP proc \fBputb\fR ?\fImap\fR? \fItext\fR Append a line of text to a variable\&. Optionally apply a string mapping\&. .TP proc \fBtcl::dict::getnull\fR \fIdictionary\fR ?\fIelement\fR? ?\fBelement\&.\&.\&.\fR? If the path (given by the list of elements) exists, return that value\&. Otherwise return an empty string\&. Designed to replace .CS if {[dict exists $dictionary {*}$args]} { return [dict get $dictionary {*}$args] } else { return {} } .CE .sp Example: .CS set value [dict getnull $arglist $option] .CE .TP proc \fBtcl::dict::is_dict\fR \fId\fR Test if value is a dict\&. .sp This command is added to the \fBdict\fR ensemble as \fBdict is_dict\fR .TP proc \fBdicttool::is_branch\fR \fIdict\fR \fIpath\fR Return true if the element with the value is a dict\&. is given as a list to descend into sub-dicts of the current dict\&. The rules are as follows: .RS .IP [1] If the last character of the last element of is a colon (:) return false .IP [2] If the last character of the last element of is a slash (/) return true .IP [3] If a sub-element if named \fB\&.info\fR is present return true .RE .sp .sp This command is added to the \fBdict\fR ensemble as \fBdicttool::is_branch\fR .sp Example: .CS > set mydict {sub/ {sub/ {field {A block of text}}} > dicttool::is_branch $mydict sub/ 1 > dicttool::is_branch $mydict {sub/ sub/} 1 > dicttool::is_branch $mydict {sub/ sub/ field} 0 .CE .TP proc \fBdicttool::print\fR \fIdict\fR Output a dictionary as an indented stream of data suitable for output to the screen\&. The system uses the rules for \fBdicttool::is_branch\fR to determine if an value in a dictionary is a leaf or a branch\&. .sp Example: .CS > set mydict {sub/ {sub/ {field {A block of text}}} > dicttool::print $mydict sub/ { sub/ { field {A block of text} } } .CE .TP proc \fBdicttool::_dictputb\fR \fIlevel\fR \fIvarname\fR \fIdict\fR Helper function for ::dicttool::print Formats the string representation for a dictionary element within a human readable stream of lines, and determines if it needs to call itself with further indentation to express a sub-branch .TP proc \fBdicttool::sanitize\fR \fIdict\fR Output a dictionary removing any \&. entries added by \fBdicttool::merge\fR .TP proc \fBdicttool::_sanitizeb\fR \fIpath\fR \fIvarname\fR \fIdict\fR Helper function for ::dicttool::sanitize Formats the string representation for a dictionary element within a human readable stream of lines, and determines if it needs to call itself with further indentation to express a sub-branch .TP proc \fBdicttool::canonical\fR \fIrawpath\fR Return the path as a canonical path for dicttool with all branch keys ending in a / and the final element ending in a / if the final element in the path ended in a / This command will also break arguments up if they contain /\&. .sp Example: .CS > dicttool::canonical foo bar baz bang foo/ bar/ baz/ bang > dicttool::canonical foo bar baz bang/ foo/ bar/ baz/ bang/ > dicttool::canonical foo bar baz bang: foo/ bar/ baz/ bang > dicttool::canonical foo/bar/baz bang: foo/ bar/ baz/ bang > dicttool::canonical foo/bar/baz/bang foo/ bar/ baz/ bang .CE .TP proc \fBdicttool::storage\fR \fIrawpath\fR Return the path as a storage path for dicttool with all branch terminators removed\&. This command will also break arguments up if they contain /\&. .sp Example: .CS > dicttool::storage foo bar baz bang foo bar baz bang > dicttool::storage foo bar baz bang/ foo bar baz bang > dicttool::storage foo bar baz bang: foo bar baz bang > dicttool::storage foo/bar/baz bang: foo bar baz bang > dicttool::storage foo/bar/baz/bang foo bar baz bang .CE .TP proc \fBdicttool::dictset\fR \fIvarname\fR ?\fIargs\fR? Set an element with a recursive dictionary, marking all branches on the way down to the final element\&. If the value does not exists in the nested dictionary it is added as a leaf\&. If the value already exists as a branch the value given is merged if the value is a valid dict\&. If the incoming value is not a valid dict, the value overrides the value stored, and the value is treated as a leaf from then on\&. .sp Example: .CS > set r {} > ::dicttool::dictset r option color default Green \&. 1 option {\&. 1 color {\&. 1 default Green}} > ::dicttool::dictset r option {Something not dictlike} \&. 1 option {Something not dictlike} # Note that if the value is not a dict, and you try to force it to be # an error with be thrown on the merge > ::dicttool::dictset r option color default Blue missing value to go with key .CE .TP proc \fBdicttool::dictmerge\fR \fIvarname\fR ?\fIargs\fR? A recursive form of dict merge, intended for modifying variables in place\&. .sp Example: .CS > set mydict {sub/ {sub/ {description {a block of text}}}} > ::dicttool::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}] > dicttool::print $mydict sub/ { sub/ { description {a block of text} field {another block of text} } } .CE .TP proc \fBdicttool::merge\fR ?\fIargs\fR? A recursive form of dict merge .sp A routine to recursively dig through dicts and merge adapted from http://stevehavelka\&.com/tcl-dict-operation-nested-merge/ .sp Example: .CS > set mydict {sub/ {sub/ {description {a block of text}}}} > set odict [dicttool::merge $mydict {sub/ {sub/ {field {another block of text}}}}] > dicttool::print $odict sub/ { sub/ { description {a block of text} field {another block of text} } } .CE .TP \fBldelete\fR \fIvarname\fR \fIargs\fR This command will delete all instances of each element in \fIargs\fR from \fIvarname\fR\&. .TP proc \fBladd\fR \fIvarname\fR ?\fIelement\fR? ?\fBelement\&.\&.\&.\fR? Add elements to a list if that are not already present in the list\&. As a side effect, if variable does not exists, create it as an empty list\&. .sp Example: .CS ladd contents foo bar puts $contents > foo bar ladd contents foo bar baz bang puts $contents > foo bar baz bang .CE .TP proc \fBldelete\fR \fIvarname\fR ?\fIelement\fR? ?\fBelement\&.\&.\&.\fR? Delete all instances of the elements given from a list contained in \&. If the variable does exist this is a noop\&. .sp Example: .CS set contents {foo bar baz bang foo foo foo} ldelete contents foo puts $contents > bar baz bang .CE .TP proc \fBlrandom\fR \fIlist\fR Return a random element from .PP .SH AUTHORS Sean Woods \fImailto:<yoda@etoyoc\&.com>\fR .PP .SH "BUGS, IDEAS, FEEDBACK" This document, and the package it describes, will undoubtedly contain bugs and other problems\&. Please report such in the category \fIdict\fR of the \fITcllib Trackers\fR [http://core\&.tcl\&.tk/tcllib/reportlist]\&. Please also report any ideas for enhancements you may have for either |
︙ | ︙ | |||
369 370 371 372 373 374 375 | left-most button in the secondary navigation bar\&. .SH KEYWORDS dict .SH CATEGORY Utilities .SH COPYRIGHT .nf | | | 593 594 595 596 597 598 599 600 601 602 | left-most button in the secondary navigation bar\&. .SH KEYWORDS dict .SH CATEGORY Utilities .SH COPYRIGHT .nf Copyright (c) 2018 Sean Woods <yoda@etoyoc\&.com> .fi |
Changes to idoc/man/files/modules/doctools/cvs.n.
︙ | ︙ |
Changes to idoc/man/files/modules/doctools/doctools_lang_intro.n.
︙ | ︙ |
Changes to idoc/man/files/modules/fumagic/cfront.n.
︙ | ︙ | |||
297 298 299 300 301 302 303 | This package provides the frontend of a compiler of magic(5) files into recognizers based on the \fBfileutil::magic::rt\fR recognizer runtime package\&. For the generator backed used by this compiler see the package \fBfileutil::magic::cgen\fR\&. .SH COMMANDS .TP \fB::fileutil::magic::cfront::compile\fR \fIpath\fR\&.\&.\&. | | | | > > | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | This package provides the frontend of a compiler of magic(5) files into recognizers based on the \fBfileutil::magic::rt\fR recognizer runtime package\&. For the generator backed used by this compiler see the package \fBfileutil::magic::cgen\fR\&. .SH COMMANDS .TP \fB::fileutil::magic::cfront::compile\fR \fIpath\fR\&.\&.\&. This command takes the paths of one or more files and directories and compiles all the files, and the files in all the directories into a single analyzer for all the file types specified in these files\&. It returns a list whose first item is a list per-file dictionaries of analyzer scripts and whose second item is a list of analyzer commands\&. .sp All the files have to be in the format specified by magic(5)\&. .sp The result of the command is a Tcl script containing the generated recognizer\&. .TP \fB::fileutil::magic::cfront::procdef\fR \fIprocname\fR \fIpath\fR\&.\&.\&. |
︙ | ︙ |
Changes to idoc/man/files/modules/fumagic/rtcore.n.
︙ | ︙ | |||
277 278 279 280 281 282 283 | .sp package require \fBfileutil::magic::rt ?2\&.0?\fR .sp \fB::fileutil::magic::rt::>\fR .sp \fB::fileutil::magic::rt::<\fR .sp | < < | | < < | | | | < < < < | < < | < < | | | | | | < < < | | < > | | | < < < < < < < < < < < < < < < < < < < < < < > > > > | < < < < < < < < | | < | < < < < | | < | < < < | < > | | < | | | < < < < | < < | < < < < < < | < < < < < < < < | | < < < < < < > | > | < < < < | | 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 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 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 | .sp package require \fBfileutil::magic::rt ?2\&.0?\fR .sp \fB::fileutil::magic::rt::>\fR .sp \fB::fileutil::magic::rt::<\fR .sp \fB::fileutil::magic::rt::new\fR \fIchan\fR \fInamed\fR \fIanalyze\fR .sp \fB::fileutil::magic::rt::file_start\fR \fIname\fR .sp \fB::fileutil::magic::rt::emit\fR \fImsg\fR .sp \fB::fileutil::magic::rt::O\fR \fIwhere\fR .sp \fB::fileutil::magic::rt::R\fR \fIwhere\fR .sp \fB::fileutil::magic::rt::Nv\fR \fItype\fR \fIoffset\fR \fIcompinvert\fR \fIcomp\fR \fIexpected\fR .sp \fB::fileutil::magic::rt::N\fR \fItype\fR \fIoffset\fR \fItestinvert\fR \fIcompinvert\fR \fImod\fR \fImand\fR \fIcomp\fR \fIexpected\fR .sp \fB::fileutil::magic::rt::S\fR \fItype\fR \fIoffset\fR \fItestinvert\fR \fImod\fR \fImand\fR \fIcomp\fR \fIval\fR .sp \fB::fileutil::magic::rt::L\fR \fInewlevel\fR .sp \fB::fileutil::magic::rt::I\fR \fIoffset\fR \fIit\fR \fIioi\fR \fIioo\fR \fIiir\fR \fIio\fR .sp \fB::fileutil::magic::rt::R\fR \fIoffset\fR .sp \fB::fileutil::magic::rt::U\fR \fIfileindex\fR \fIname\fR .sp .BE .SH DESCRIPTION .PP This package provides the runtime core for file type recognition engines written in pure Tcl and is thus used by all other packages in this module such as \fBfileutil::magic::filetype\fR and the two compiler packages \fBfileutil::magic::cgen\fR and \fBfileutil::magic::cfront\fR\&. .SH COMMANDS .TP \fB::fileutil::magic::rt::>\fR Increment the level and perform related housekeeping .TP \fB::fileutil::magic::rt::<\fR Decrement the level and perform related housekeeping .TP \fB::fileutil::magic::rt::new\fR \fIchan\fR \fInamed\fR \fIanalyze\fR Create a new command which returns one description of the file each time it is called, and a code of \fIbreak\fR when there are no more descriptions\&. \fIchan\fR is the channel containing the data to describe\&. The channel configuration is then managed as needed\&. \fInamed\fR is a dictionary of named tests, as generated by \fBfileutil::magic::cfront::compile\fR\&. \fItest\fR is a command prefix for a routine composed of the list of commands as returned by \fBfileutil::magic::cfront::compile\fR\&. .TP \fB::fileutil::magic::rt::file_start\fR \fIname\fR This command marks the start of a magic file when debugging\&. It returns the empty string as its result\&. .TP \fB::fileutil::magic::rt::emit\fR \fImsg\fR This command adds the text \fImsg\fR to the result buffer\&. The message may contain the following special character sequences\&. They will be replaced with buffered values before the message is added to the result\&. The command returns the empty string as its result\&. .RS .TP \fB\\b\fR This sequence is removed .TP \fB%s\fR Replaced with the last buffered string value\&. .TP \fB%ld\fR Replaced with the last buffered numeric value\&. .TP \fB%d\fR See above\&. .TP \fB${x:\&.\&.\&.?\&.\&.\&.}\fR Substitute one string if the file is executable, and another string otherwise\&. .RE .TP \fB::fileutil::magic::rt::O\fR \fIwhere\fR Produce an offset from \fIwhere\fR, relative to the cursor one level up\&. Produce an offset from \fIwhere\fR, relative to the offset one level up\&. .TP \fB::fileutil::magic::rt::Nv\fR \fItype\fR \fIoffset\fR \fIcompinvert\fR \fIcomp\fR \fIexpected\fR A limited form of \fB::fileutile::magic::rt::N\fR that only checks for equality and can't be told to invert the test\&. .TP \fB::fileutil::magic::rt::N\fR \fItype\fR \fIoffset\fR \fItestinvert\fR \fIcompinvert\fR \fImod\fR \fImand\fR \fIcomp\fR \fIexpected\fR Fetch the numeric value with \fItype\fR from the absolute location \fIoffset\fR, compare it with \fIexpected\fR using \fIcomp\fR as the comparision operator, and returns the result\&. .sp The argument \fIcomp\fR must be one of Tcl's comparison operators\&. .CS <comp> <fetched-and-masked-value> <comp> <expected> .CE .sp The special comparison operator \fBx\fR signals that no comparison should be done, or, in other words, that the fetched value will always match \fIval\fR\&. .TP \fB::fileutil::magic::rt::S\fR \fItype\fR \fIoffset\fR \fItestinvert\fR \fImod\fR \fImand\fR \fIcomp\fR \fIval\fR Like \fB::fileutil::magic::rt::N\fR except that it fetches and compares string types , not numeric data\&. .TP \fB::fileutil::magic::rt::L\fR \fInewlevel\fR Sets the current level in the calling context to \fInewlevel\fR\&. The command returns the empty string as its result\&. .TP \fB::fileutil::magic::rt::I\fR \fIoffset\fR \fIit\fR \fIioi\fR \fIioo\fR \fIiir\fR \fIio\fR Calculates an offset based on an initial offset and the provided modifiers\&. .TP \fB::fileutil::magic::rt::R\fR \fIoffset\fR Given an initial offset, calculates an offset relative to the cursor at the next level up\&. The cursor is the position in the data one character after the data extracted from the file one level up\&. .sp .TP \fB::fileutil::magic::rt::U\fR \fIfileindex\fR \fIname\fR Add a level and use a named test script\&. .PP .SH "NUMERIC TYPES" .TP \fBbyte\fR 8-bit integer .TP \fBshort\fR |
︙ | ︙ |
Changes to idoc/man/files/modules/htmlparse/htmlparse.n.
︙ | ︙ |
Changes to idoc/man/files/modules/httpd/httpd.n.
︙ | ︙ | |||
273 274 275 276 277 278 279 280 281 282 283 284 285 286 | .BS .SH NAME httpd \- A TclOO and coroutine based web server .SH SYNOPSIS package require \fBTcl 8\&.6\fR .sp package require \fBuuid \fR .sp package require \fBclay \fR .sp package require \fBcoroutine \fR .sp package require \fBfileutil \fR .sp | > > > > > > > > > > | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | .BS .SH NAME httpd \- A TclOO and coroutine based web server .SH SYNOPSIS package require \fBTcl 8\&.6\fR .sp package require \fBuuid \fR .sp package require \fBsha1 \fR .sp package require \fBdicttool \fR .sp package require \fBoo::meta \fR .sp package require \fBoo::dialect \fR .sp package require \fBtool \fR .sp package require \fBclay \fR .sp package require \fBcoroutine \fR .sp package require \fBfileutil \fR .sp |
︙ | ︙ |
Changes to idoc/man/files/modules/ldap/ldap.n.
︙ | ︙ |
Changes to idoc/man/files/modules/ldap/ldapx.n.
︙ | ︙ |
Changes to idoc/man/files/modules/log/log.n.
︙ | ︙ |
Changes to idoc/man/files/modules/math/math_geometry.n.
︙ | ︙ |
Changes to idoc/man/files/modules/math/statistics.n.
︙ | ︙ |
Changes to idoc/man/files/modules/math/trig.n.
︙ | ︙ |
Changes to idoc/man/files/modules/mime/mime.n.
︙ | ︙ | |||
268 269 270 271 272 273 274 | .. .\" # MT - "empty" string .de MT .QW "" .. .BS .SH NAME | | | | | | | | | | | | | < | | < < < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < < < < < < < < < | | < | < < < < | | < < < < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < | | 268 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 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 | .. .\" # MT - "empty" string .de MT .QW "" .. .BS .SH NAME mime \- Manipulation of Internet messages .SH SYNOPSIS package require \fBTcl 8\&.5\fR .sp package require \fBmime ?1\&.6\&.3?\fR .sp \fB::mime::initialize\fR ?\fB-canonical\fR \fItype/subtype\fR? ?\fB-params\fR \fIdictionary\fR? ?\fB-encoding\fR \fIvalue\fR? ?\fB-headers\fR \fIdictionary\fR? ?(\fB-chan\fR \fIname\fR | \fB-file\fR \fIname\fR | \fB-string\fR \fIvalue\fR | \fB-parts\fR \fIparts\fR)? .sp \fB::mime::body\fR \fItoken\fR ?\fB-decode\fR? ?\fB-blocksize\fR \fIoctets\fR?" .sp \fB::mime::datetime\fR (\fItime\fR | \fB-now\fR) \fIproperty\fR .sp \fB::mime::finalize\fR \fItoken\fR ?\fB-subordinates\fR \fBall\fR | \fBdynamic\fR | \fBnone\fR? .sp \fB::mime::header\fR \fBserialize\fR \fIvalue\fR \fIparameters\fR .sp \fB::mime::header\fR \fBget\fR \fItoken\fR ?\fIkey\fR | \fB-names\fR? .sp \fB::mime::header\fR \fBset\fR \fItoken\fR \fIname value\fR ?\fIparameters\fR ?\fB-mode\fR \fBwrite\fR | \fBappend\fR | \fBdelete\fR?? .sp \fB::mime::property\fR \fItoken\fR ?\fIname\fR | \fB-names\fR? .sp \fB::mime::serialize\fR \fItoken\fR ?\fB-chan\fR \fIchannel\fR? .sp \fB::mime::parseaddress\fR \fIaddresses\fR .sp \fB::mime::mapencoding\fR \fIencoding_name\fR .sp \fB::mime::reversemapencoding\fR \fIcharset_type\fR .sp .BE .SH DESCRIPTION .PP Provides commands to create and manipulate Internet messages\&. .TP \fB::mime::initialize\fR ?\fB-canonical\fR \fItype/subtype\fR? ?\fB-params\fR \fIdictionary\fR? ?\fB-encoding\fR \fIvalue\fR? ?\fB-headers\fR \fIdictionary\fR? ?(\fB-chan\fR \fIname\fR | \fB-file\fR \fIname\fR | \fB-string\fR \fIvalue\fR | \fB-parts\fR \fIparts\fR)? Parses a message and returns a token for the message\&. One of \fB-chan\fR, \fB-file\fR, or \fB-string\fR must be provided as the source of the input\&. If \fB-canonical\fR is provided the input is the body only and is already formatted according to the provided \fItype/subtype\fR, and therefore should not be parsed\&. If \fIparts\fR is provided it is a list of tokens for messages that comprise a \fBmultipart/mixed\fR message body\&. \fB-params\fR is a multidict (a dictionary where the keys may not be unique) of parameters for the \fBContent-Type\fR header\&. \fB-headers\fR is a multidict of headers\&. .sp \fB-encoding\fR sets the \fBContent-Transfer-Encoding\fR\&. .TP \fB::mime::body\fR \fItoken\fR ?\fB-decode\fR? ?\fB-blocksize\fR \fIoctets\fR?" Returns as a string in canonical form the body of the message corresponding to \fItoken\fR\&. .sp If \fB-blocksize\fR is provided, returns a command that itself returns up to the next \fIoctets\fR of the message each time it's called, and returns a code of \fBbreak\fR when finished, deleting itself as well\&. If \fIoctets\fR is the empty string, a default value is used\&. Pauses the current coroutine as needed to wait for input\&. .sp \fB-decode\fR converts the message body from the character set it is encoded in\&. .TP \fB::mime::datetime\fR (\fItime\fR | \fB-now\fR) \fIproperty\fR Returns the \fIproperty\fR of \fItime\fR, which 822-style date-time value\&. .sp Available properties and their ranges are: .RS .TP \fBhour\fR 0 \&.\&. 23 .TP \fBlmonth\fR January, February, \&.\&.\&., December |
︙ | ︙ | |||
550 551 552 553 554 555 556 557 558 | .TP \fByear\fR 1900 \&.\&.\&. .TP \fBzone\fR -720 \&.\&. 720 (minutes east of GMT) .RE .TP \fB::mime::mapencoding\fR \fIencoding_name\fR | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 | .TP \fByear\fR 1900 \&.\&.\&. .TP \fBzone\fR -720 \&.\&. 720 (minutes east of GMT) .RE .TP \fB::mime::finalize\fR \fItoken\fR ?\fB-subordinates\fR \fBall\fR | \fBdynamic\fR | \fBnone\fR? Destroys the message corresponding to \fItoken\fR and returns the empty string\&. .sp \fB-subordinates\fR specifies which messages comprising the body should also be destroyed\&. The default value is \fBdynamic\fR, which destroys all component messages that were created by \fB::mime::initialize\fR\&. .TP \fB::mime::header\fR \fBserialize\fR \fIvalue\fR \fIparameters\fR Serialize a header\&. .TP \fB::mime::header\fR \fBget\fR \fItoken\fR ?\fIkey\fR | \fB-names\fR? Returns the header of a message as a multidict where each value is a list containing the header value and any parameters for that value\&. .sp If \fIname\fR is provided returns a list of values for that name, without regard to case\&. .sp If \fB-names\fR is provided, returns a list of all header names\&. .TP \fB::mime::header\fR \fBset\fR \fItoken\fR \fIname value\fR ?\fIparameters\fR ?\fB-mode\fR \fBwrite\fR | \fBappend\fR | \fBdelete\fR?? If \fBappend\fR is provided, creates a new header named \fIname\fR with the value of \fIvalue\fR is added\&. If \fBwrite\fR is provided, deletes any existing headers whose names match \fIkey\fR and then creates a new header named \fIkey\fR with the value of \fIvalue\fR\&. If \fBdelete\fR is provided, deletes any existing header having a name that matches \fIkey\fR\&. \fIparameters\fR is a dictionary of parameters for the header\&. Returns a list of strings containing the previous value associated with the key\&. .sp The value for \fB-mode\fR is one of: .RS .TP \fBwrite\fR The \fIkey\fR/\fIvalue\fR is either created or overwritten (the default)\&. .TP \fBappend\fR Appends a new \fIkey\fR/\fIvalue\fR\&. .TP \fBdelete\fR Removes all values associated with the key\&. \fIvalue\fR is ignored\&. .RE .TP \fB::mime::property\fR \fItoken\fR ?\fIname\fR | \fB-names\fR? Returns a dictionary of message properties\&. If \fIname\fR is provided, only the corresponding value is returned\&. If \fB-names\fR is provided, a list of all property names is returned\&. .sp properties: .RS .TP \fBcontent\fR The type/subtype of the content .TP \fBencoding\fR The "Content-Transfer-Encoding" .TP \fBparams\fR A list of "Content-Type" parameters .TP \fBparts\fR A list of tokens for messages that should comprise a multipart body\&. Only exists if there are any such messages\&. .TP \fBsize\fR The approximate size of the unencoded content\&. .RE .TP \fB::mime::serialize\fR \fItoken\fR ?\fB-chan\fR \fIchannel\fR? Return the serialization of the message corresponding to \fItoken\fR\&. If \fB-chan\fR is provided, write the message to \fIchannel\fR and return the empty string\&. Pauses the current coroutine as needed to wait for input to become available\&. .TP \fB::mime::parseaddress\fR \fIaddresses\fR Returns a list of describing the comma-separated 822-style \fIaddresses\fR\&. .sp Each dictionary contains the following keys, whose values may be the empty string: .RS .TP \fBaddress\fR local@domain .TP \fBcomment\fR 822-style comment .TP \fBdomain\fR the domain part (rhs) .TP \fBerror\fR non-empty on a parse error .TP \fBgroup\fR this address begins a group .TP \fBfriendly\fR user-friendly rendering .TP \fBlocal\fR the local part (lhs) .TP \fBmemberP\fR this address belongs to a group .TP \fBphrase\fR the phrase part .TP \fBproper\fR 822-style address specification .TP \fBroute\fR 822-style route specification (obsolete) .RE .TP \fB::mime::mapencoding\fR \fIencoding_name\fR Maps Tcl encodings onto the proper names for their MIME charset type\&. This is only done for encodings whose charset types were known\&. The remaining encodings return "" for now\&. .TP \fB::mime::reversemapencoding\fR \fIcharset_type\fR Maps MIME charset types onto tcl encoding names\&. Those that are unknown return ""\&. .PP .SH "KNOWN BUGS" .TP Tcllib Bug #447037 This problem affects only people which are using Tcl and Mime on a 64-bit system\&. The currently recommended fix for this problem is to |
︙ | ︙ |
Changes to idoc/man/files/modules/namespacex/namespacex.n.
︙ | ︙ | |||
294 295 296 297 298 299 300 301 302 303 304 305 306 307 | .sp \fB::namespacex info allvars\fR \fInamespace\fR .sp \fB::namespacex normalize\fR \fInamespace\fR .sp \fB::namespacex info vars\fR \fInamespace\fR ?\fIpattern\fR? .sp \fB::namespacex state get\fR \fInamespace\fR .sp \fB::namespacex state set\fR \fInamespace\fR \fIdict\fR .sp \fB::namespacex state drop\fR \fInamespace\fR .sp \fB::namespacex strip\fR \fIprefix\fR \fInamespaces\fR | > > | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | .sp \fB::namespacex info allvars\fR \fInamespace\fR .sp \fB::namespacex normalize\fR \fInamespace\fR .sp \fB::namespacex info vars\fR \fInamespace\fR ?\fIpattern\fR? .sp \fB::namespacex normalize\fR \fInamespace\fR .sp \fB::namespacex state get\fR \fInamespace\fR .sp \fB::namespacex state set\fR \fInamespace\fR \fIdict\fR .sp \fB::namespacex state drop\fR \fInamespace\fR .sp \fB::namespacex strip\fR \fIprefix\fR \fInamespaces\fR |
︙ | ︙ | |||
401 402 403 404 405 406 407 408 409 410 411 412 413 414 | \fB::namespacex info vars\fR \fInamespace\fR ?\fIpattern\fR? Returns a list containing the names of all variables in the specified \fInamespace\fR\&. If the \fIpattern\fR argument is specified, then only variables matching \fIpattern\fR are returned\&. Matching is determined using the same rules as for \fBstring match\fR\&. .TP \fB::namespacex state get\fR \fInamespace\fR Returns a dictionary holding the names and values of all variables in the specified \fInamespace\fR and its child namespaces\&. .sp Note that the names are all relative to \fInamespace\fR, and \fInot\fR fully qualified\&. .TP | > > > > | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | \fB::namespacex info vars\fR \fInamespace\fR ?\fIpattern\fR? Returns a list containing the names of all variables in the specified \fInamespace\fR\&. If the \fIpattern\fR argument is specified, then only variables matching \fIpattern\fR are returned\&. Matching is determined using the same rules as for \fBstring match\fR\&. .TP \fB::namespacex normalize\fR \fInamespace\fR Returns the absolute name of \fInamespace\fR, which is resolved relative to the namespace of the caller, with all unneeded colon characters removed\&. .TP \fB::namespacex state get\fR \fInamespace\fR Returns a dictionary holding the names and values of all variables in the specified \fInamespace\fR and its child namespaces\&. .sp Note that the names are all relative to \fInamespace\fR, and \fInot\fR fully qualified\&. .TP |
︙ | ︙ |
Changes to idoc/man/files/modules/nns/nns_client.n.
︙ | ︙ |
Changes to idoc/man/files/modules/nns/nns_server.n.
︙ | ︙ |
Changes to idoc/man/files/modules/oometa/oometa.n.
︙ | ︙ | |||
352 353 354 355 356 357 358 | \fBoo::meta::info branchget\fR ?\fIkey\fR? ?\&.\&.\&.? Returns a dict representation of the element at \fIargs\fR, but with any trailing : removed from field names\&. .CS ::oo::meta::info $myclass set option color {default: green widget: colorselect} puts [::oo::meta::info $myclass get option color] | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | \fBoo::meta::info branchget\fR ?\fIkey\fR? ?\&.\&.\&.? Returns a dict representation of the element at \fIargs\fR, but with any trailing : removed from field names\&. .CS ::oo::meta::info $myclass set option color {default: green widget: colorselect} puts [::oo::meta::info $myclass get option color] > {default green widget color} puts [::oo::meta::info $myclass branchget option color] > {default green widget color} .CE .TP \fBoo::meta::info branchset\fR ?\fIkey\&.\&.\&.\fR? \fIkey\fR \fIvalue\fR Merges \fIdict\fR with any other information contaned at node ?\fIkey\&.\&.\&.\fR?, and adding a trailing : |
︙ | ︙ |
Changes to idoc/man/files/modules/pop3d/pop3d.n.
︙ | ︙ |
Changes to idoc/man/files/modules/pt/pt_peg_op.n.
︙ | ︙ |
Changes to idoc/man/files/modules/smtpd/smtpd.n.
︙ | ︙ |
Changes to idoc/man/files/modules/stooop/switched.n.
︙ | ︙ |
Changes to idoc/man/files/modules/tepam/tepam_doc_gen.n.
︙ | ︙ |
Changes to idoc/man/files/modules/tepam/tepam_procedure.n.
︙ | ︙ |
Changes to idoc/man/files/modules/textutil/adjust.n.
︙ | ︙ |
Changes to idoc/man/files/modules/websocket/websocket.n.
︙ | ︙ |
Changes to idoc/man/index.n.
︙ | ︙ | |||
11265 11266 11267 11268 11269 11270 11271 11272 11273 11274 11275 11276 11277 11278 | page_util_flow .TP \fBfiles/modules/page/page_util_norm_lemon\&.n\fR page_util_norm_lemon .TP \fBfiles/modules/page/page_util_norm_peg\&.n\fR page_util_norm_peg .RE trigonometry .RS .TP \fBfiles/modules/math/trig\&.n\fR math::trig .RE | > > > > > > | 11265 11266 11267 11268 11269 11270 11271 11272 11273 11274 11275 11276 11277 11278 11279 11280 11281 11282 11283 11284 | page_util_flow .TP \fBfiles/modules/page/page_util_norm_lemon\&.n\fR page_util_norm_lemon .TP \fBfiles/modules/page/page_util_norm_peg\&.n\fR page_util_norm_peg .RE trigonometry .RS .TP \fBfiles/modules/math/trig\&.n\fR math::trig .RE trigonometry .RS .TP \fBfiles/modules/math/trig\&.n\fR math::trig .RE |
︙ | ︙ |
Changes to idoc/man/toc.n.
︙ | ︙ | |||
873 874 875 876 877 878 879 | \fBmd5\fR \fIfiles/modules/md5/md5\&.n\fR: MD5 Message-Digest Algorithm .TP \fBmd5crypt\fR \fIfiles/modules/md5crypt/md5crypt\&.n\fR: MD5-based password encryption .TP \fBmime\fR | | | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 | \fBmd5\fR \fIfiles/modules/md5/md5\&.n\fR: MD5 Message-Digest Algorithm .TP \fBmd5crypt\fR \fIfiles/modules/md5crypt/md5crypt\&.n\fR: MD5-based password encryption .TP \fBmime\fR \fIfiles/modules/mime/mime\&.n\fR: Manipulation of Internet messages .TP \fBmpexpand\fR \fIfiles/modules/doctools/mpexpand\&.n\fR: Markup processor .TP \fBmultiplexer\fR \fIfiles/modules/multiplexer/multiplexer\&.n\fR: One-to-many communication with sockets\&. .TP |
︙ | ︙ |
Changes to idoc/www/index.html.
︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 | <a href="tcllib/files/modules/math/probopt.html"> math::probopt </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="proc"> proc </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/lambda/lambda.html"> lambda </a> </td></tr> | | | | | | | | | | | | | | | 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 | <a href="tcllib/files/modules/math/probopt.html"> math::probopt </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="proc"> proc </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/lambda/lambda.html"> lambda </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="procedure"> procedure </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/interp/deleg_proc.html"> deleg_proc </a> · <a href="tcllib/files/modules/tepam/tepam_introduction.html"> tepam </a> · <a href="tcllib/files/modules/tepam/tepam_procedure.html"> tepam::procedure </a> </td></tr> <tr class="#doctools_idxodd" valign=top> <td class="#doctools_idxleft" width="35%"><a name="procedure_documentation"> procedure documentation </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/tepam/tepam_doc_gen.html"> tepam::doc_gen </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="processman"> processman </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/processman/processman.html"> processman </a> </td></tr> <tr class="#doctools_idxodd" valign=top> <td class="#doctools_idxleft" width="35%"><a name="producer"> producer </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/hook/hook.html"> hook </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="profile"> profile </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/profiler/profiler.html"> profiler </a> </td></tr> <tr class="#doctools_idxodd" valign=top> <td class="#doctools_idxleft" width="35%"><a name="projection"> projection </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/mapproj/mapproj.html"> mapproj </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="prospero"> prospero </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/uri/uri.html"> uri </a> </td></tr> <tr class="#doctools_idxodd" valign=top> <td class="#doctools_idxleft" width="35%"><a name="protocol"> protocol </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/asn/asn.html"> asn </a> · <a href="tcllib/files/modules/ldap/ldap.html"> ldap </a> · <a href="tcllib/files/modules/ldap/ldapx.html"> ldapx </a> · <a href="tcllib/files/modules/nns/nns_protocol.html"> nameserv::protocol </a> · <a href="tcllib/files/modules/pop3d/pop3d.html"> pop3d </a> · <a href="tcllib/files/modules/pop3d/pop3d_dbox.html"> pop3d::dbox </a> · <a href="tcllib/files/modules/pop3d/pop3d_udb.html"> pop3d::udb </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="proxy"> proxy </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/http/autoproxy.html"> autoproxy </a> </td></tr> <tr class="#doctools_idxodd" valign=top> <td class="#doctools_idxleft" width="35%"><a name="public_key_cipher"> public key cipher </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/pki/pki.html"> pki </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="publisher"> publisher </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/hook/hook.html"> hook </a> </td></tr> <tr class="#doctools_idxodd" valign=top> <td class="#doctools_idxleft" width="35%"><a name="push_down_automaton"> push down automaton </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/grammar_me/me_intro.html"> grammar::me_intro </a> · <a href="tcllib/files/modules/grammar_peg/peg.html"> grammar::peg </a> · <a href="tcllib/files/modules/grammar_peg/peg_interp.html"> grammar::peg::interp </a> · <a href="tcllib/files/apps/pt.html"> pt </a> · <a href="tcllib/files/modules/pt/pt_astree.html"> pt::ast </a> · <a href="tcllib/files/modules/pt/pt_cparam_config_critcl.html"> pt::cparam::configuration::critcl </a> · <a href="tcllib/files/modules/pt/pt_cparam_config_tea.html"> pt::cparam::configuration::tea </a> · <a href="tcllib/files/modules/pt/pt_json_language.html"> pt::json_language </a> · <a href="tcllib/files/modules/pt/pt_param.html"> pt::param </a> · <a href="tcllib/files/modules/pt/pt_pexpression.html"> pt::pe </a> · <a href="tcllib/files/modules/pt/pt_pexpr_op.html"> pt::pe::op </a> · <a href="tcllib/files/modules/pt/pt_pegrammar.html"> pt::peg </a> · <a href="tcllib/files/modules/pt/pt_peg_container.html"> pt::peg::container </a> · <a href="tcllib/files/modules/pt/pt_peg_container_peg.html"> pt::peg::container::peg </a> · <a href="tcllib/files/modules/pt/pt_peg_export.html"> pt::peg::export </a> · <a href="tcllib/files/modules/pt/pt_peg_export_container.html"> pt::peg::export::container </a> · <a href="tcllib/files/modules/pt/pt_peg_export_json.html"> pt::peg::export::json </a> · <a href="tcllib/files/modules/pt/pt_peg_export_peg.html"> pt::peg::export::peg </a> · <a href="tcllib/files/modules/pt/pt_peg_from_container.html"> pt::peg::from::container </a> · <a href="tcllib/files/modules/pt/pt_peg_from_json.html"> pt::peg::from::json </a> · <a href="tcllib/files/modules/pt/pt_peg_from_peg.html"> pt::peg::from::peg </a> · <a href="tcllib/files/modules/pt/pt_peg_import.html"> pt::peg::import </a> · <a href="tcllib/files/modules/pt/pt_peg_import_container.html"> pt::peg::import::container </a> · <a href="tcllib/files/modules/pt/pt_peg_import_json.html"> pt::peg::import::json </a> · <a href="tcllib/files/modules/pt/pt_peg_import_peg.html"> pt::peg::import::peg </a> · <a href="tcllib/files/modules/pt/pt_peg_interp.html"> pt::peg::interp </a> · <a href="tcllib/files/modules/pt/pt_peg_to_container.html"> pt::peg::to::container </a> · <a href="tcllib/files/modules/pt/pt_peg_to_cparam.html"> pt::peg::to::cparam </a> · <a href="tcllib/files/modules/pt/pt_peg_to_json.html"> pt::peg::to::json </a> · <a href="tcllib/files/modules/pt/pt_peg_to_param.html"> pt::peg::to::param </a> · <a href="tcllib/files/modules/pt/pt_peg_to_peg.html"> pt::peg::to::peg </a> · <a href="tcllib/files/modules/pt/pt_peg_to_tclparam.html"> pt::peg::to::tclparam </a> · <a href="tcllib/files/modules/pt/pt_peg_language.html"> pt::peg_language </a> · <a href="tcllib/files/modules/pt/pt_peg_introduction.html"> pt::pegrammar </a> · <a href="tcllib/files/modules/pt/pt_pgen.html"> pt::pgen </a> · <a href="tcllib/files/modules/pt/pt_rdengine.html"> pt::rde </a> · <a href="tcllib/files/modules/pt/pt_tclparam_config_nx.html"> pt::tclparam::configuration::nx </a> · <a href="tcllib/files/modules/pt/pt_tclparam_config_snit.html"> pt::tclparam::configuration::snit </a> · <a href="tcllib/files/modules/pt/pt_tclparam_config_tcloo.html"> pt::tclparam::configuration::tcloo </a> · <a href="tcllib/files/modules/pt/pt_util.html"> pt::util </a> · <a href="tcllib/files/modules/pt/pt_to_api.html"> pt_export_api </a> · <a href="tcllib/files/modules/pt/pt_from_api.html"> pt_import_api </a> · <a href="tcllib/files/modules/pt/pt_introduction.html"> pt_introduction </a> · <a href="tcllib/files/modules/pt/pt_parse_peg.html"> pt_parse_peg </a> · <a href="tcllib/files/modules/pt/pt_parser_api.html"> pt_parser_api </a> · <a href="tcllib/files/modules/pt/pt_peg_op.html"> pt_peg_op </a> </td></tr> <tr class="#doctools_idxheader"><th colspan="2"> <a name="cQ">Keywords: Q</a> </th></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="quasi_random"> quasi-random </a></td> <td class="#doctools_idxright" width="65%"> <a href="tcllib/files/modules/math/quasirandom.html"> math::quasirandom </a> </td></tr> <tr class="#doctools_idxeven" valign=top> <td class="#doctools_idxleft" width="35%"><a name="queue"> queue </a></td> <td class="#doctools_idxright" width="65%"> |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/clay/clay.html.
1 2 3 4 5 6 7 | <!DOCTYPE html><html><head> <title>clay - Clay Framework</title> <style type="text/css"><!-- HTML { background: #FFFFFF; color: black; } | > | 1 2 3 4 5 6 7 8 | <!DOCTYPE html><html><head> <title>clay - Clay Framework</title> <style type="text/css"><!-- HTML { background: #FFFFFF; color: black; } |
︙ | ︙ | |||
95 96 97 98 99 100 101 | --> <!-- Copyright &copy; 2018 Sean Woods &lt;[email protected]&gt; --> <!-- clay.n --> <body><hr> [ <a href="../../../../../../../../home">Tcllib Home</a> | | | | | | | | | | > < < | | | | | | | | < < < < < < | < | | | < < < < < < < < < < < < < < < < < < < < < < < | | | | | < | | | | | | | | | | < < < < < < < < < < | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 | --> <!-- Copyright &copy; 2018 Sean Woods &lt;[email protected]&gt; --> <!-- clay.n --> <body><hr> [ <a href="../../../../../../../../home">Tcllib Home</a> | <a href="../../../../toc.html">Main Table Of Contents</a> | <a href="../../../toc.html">Table Of Contents</a> | <a href="../../../../index.html">Keyword Index</a> | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">clay(n) 0.3 tcllib "Clay Framework"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> <p>clay - A minimalist framework for large scale OO Projects</p> </div> <div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2> <ul class="doctools_toc"> <li class="doctools_section"><a href="#toc">Table Of Contents</a></li> <li class="doctools_section"><a href="#synopsis">Synopsis</a></li> <li class="doctools_section"><a href="#section1">Description</a> <ul> <li class="doctools_subsection"><a href="#subsection1">Structured Data</a></li> <li class="doctools_subsection"><a href="#subsection2">Clay Dialect</a></li> <li class="doctools_subsection"><a href="#subsection3">Method Delegation</a></li> </ul> </li> <li class="doctools_section"><a href="#section2">Commands</a></li> <li class="doctools_section"><a href="#section3">Classes</a> <ul> <li class="doctools_subsection"><a href="#subsection4">Class oo::class</a></li> <li class="doctools_subsection"><a href="#subsection5">Class oo::object</a></li> <li class="doctools_subsection"><a href="#subsection6">Class clay::object</a></li> </ul> </li> <li class="doctools_section"><a href="#section4">AUTHORS</a></li> <li class="doctools_section"><a href="#section5">Bugs, Ideas, Feedback</a></li> <li class="doctools_section"><a href="#keywords">Keywords</a></li> <li class="doctools_section"><a href="#category">Category</a></li> <li class="doctools_section"><a href="#copyright">Copyright</a></li> </ul> </div> <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.6</b></li> <li>package require <b class="pkgname">uuid</b></li> <li>package require <b class="pkgname">oo::dialect</b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1">proc <b class="cmd">clay::ancestors</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#2">proc <b class="cmd">clay::args_to_dict</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#3">proc <b class="cmd">clay::args_to_options</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#4">proc <b class="cmd">clay::dynamic_arguments</b> <i class="arg">ensemble</i> <i class="arg">method</i> <i class="arg">arglist</i> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#5">proc <b class="cmd">clay::dynamic_wrongargs_message</b> <i class="arg">arglist</i></a></li> <li><a href="#6">proc <b class="cmd">clay::is_dict</b> <i class="arg">d</i></a></li> <li><a href="#7">proc <b class="cmd">clay::is_null</b> <i class="arg">value</i></a></li> <li><a href="#8">proc <b class="cmd">clay::leaf</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#9">proc <b class="cmd">clay::path</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#10">proc <b class="cmd">clay::script_path</b></a></li> <li><a href="#11">proc <b class="cmd">clay::NSNormalize</b> <i class="arg">qualname</i></a></li> <li><a href="#12">proc <b class="cmd">clay::uuid_generate</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#13">proc <b class="cmd">clay::dynamic_methods</b> <i class="arg">class</i></a></li> <li><a href="#14">proc <b class="cmd">clay::dynamic_methods_class</b> <i class="arg">thisclass</i></a></li> <li><a href="#15">proc <b class="cmd">clay::define::Array</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></li> <li><a href="#16">proc <b class="cmd">clay::define::component</b> <i class="arg">name</i> <i class="arg">info</i></a></li> <li><a href="#17">proc <b class="cmd">clay::define::constructor</b> <i class="arg">arglist</i> <i class="arg">rawbody</i></a></li> <li><a href="#18">proc <b class="cmd">clay::define::class_method</b> <i class="arg">name</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li> <li><a href="#19">proc <b class="cmd">clay::define::clay</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#20">proc <b class="cmd">clay::define::destructor</b> <i class="arg">rawbody</i></a></li> <li><a href="#21">proc <b class="cmd">clay::define::Dict</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></li> <li><a href="#22">proc <b class="cmd">clay::define::Variable</b> <i class="arg">name</i> <span class="opt">?<i class="arg">default</i> <b class="const"></b>?</span></a></li> <li><a href="#23">proc <b class="cmd">clay::object_create</b> <i class="arg">objname</i> <span class="opt">?<i class="arg">class</i> <b class="const"></b>?</span></a></li> <li><a href="#24">proc <b class="cmd">clay::object_rename</b> <i class="arg">object</i> <i class="arg">newname</i></a></li> <li><a href="#25">proc <b class="cmd">clay::object_destroy</b> <i class="arg">objname</i></a></li> <li><a href="#26">proc <b class="cmd">clay::ensemble_methodbody</b> <i class="arg">ensemble</i> <i class="arg">einfo</i></a></li> <li><a href="#27">proc <b class="cmd">clay::define::Ensemble</b> <i class="arg">rawmethod</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li> <li><a href="#28">method <b class="cmd">clay ancestors</b></a></li> <li><a href="#29">method <b class="cmd">clay dump</b></a></li> <li><a href="#30">method <b class="cmd">clay find</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#31">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#32">method <b class="cmd">clay GET</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#33">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></li> <li><a href="#34">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></li> <li><a href="#35">method <b class="cmd">clay search</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#36">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></li> <li><a href="#37">method <b class="cmd">clay ancestors</b></a></li> <li><a href="#38">method <b class="cmd">clay cget</b> <i class="arg">field</i></a></li> <li><a href="#39">method <b class="cmd">clay delegate</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">object</i>?</span></a></li> <li><a href="#40">method <b class="cmd">clay dump</b></a></li> <li><a href="#41">method <b class="cmd">clay ensemble_map</b></a></li> <li><a href="#42">method <b class="cmd">clay eval</b> <i class="arg">script</i></a></li> <li><a href="#43">method <b class="cmd">clay evolve</b></a></li> <li><a href="#44">method <b class="cmd">clay exists</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#45">method <b class="cmd">clay flush</b></a></li> <li><a href="#46">method <b class="cmd">clay forward</b> <i class="arg">method</i> <i class="arg">object</i></a></li> <li><a href="#47">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#48">method <b class="cmd">clay leaf</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#49">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></li> <li><a href="#50">method <b class="cmd">clay mixin</b> <i class="arg">class</i> <span class="opt">?<b class="option">class...</b>?</span></a></li> <li><a href="#51">method <b class="cmd">clay mixinmap</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">classes</i>?</span></a></li> <li><a href="#52">method <b class="cmd">clay provenance</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></li> <li><a href="#53">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></li> <li><a href="#54">method <b class="cmd">clay source</b> <i class="arg">filename</i></a></li> <li><a href="#55">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></li> <li><a href="#56">method <b class="cmd">InitializePublic</b></a></li> <li><a href="#57">method <b class="cmd">InitializePublic</b></a></li> </ul> </div> </div> <div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2> <p>Clay introduces a method ensemble to both <b class="class">oo::class</b> and <b class="class">oo::object</b> called clay. This ensemble handles all of the high level interactions within the framework. Clay stores structured data. Clan manages method delegation. Clay has facilities to |
︙ | ︙ | |||
343 344 345 346 347 348 349 | $A <counter> value 1 </pre> </div> </div> <div id="section2" class="doctools_section"><h2><a name="section2">Commands</a></h2> <dl class="doctools_definitions"> | < < < < < < < < < | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | | < < < < < < < < < < < < < < | | < < | > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | | | | | < < < < < < < < | | < < < < < < < < < < < < | | | < < | < < < | | < | < < < < < < < < < < < < | | | | | | | | | | | < < | < < | | | | | | | | | | | | | | | | < < | | | > > > > > > > > > | 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 | $A <counter> value 1 </pre> </div> </div> <div id="section2" class="doctools_section"><h2><a name="section2">Commands</a></h2> <dl class="doctools_definitions"> <dt><a name="1">proc <b class="cmd">clay::ancestors</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="2">proc <b class="cmd">clay::args_to_dict</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="3">proc <b class="cmd">clay::args_to_options</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="4">proc <b class="cmd">clay::dynamic_arguments</b> <i class="arg">ensemble</i> <i class="arg">method</i> <i class="arg">arglist</i> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="5">proc <b class="cmd">clay::dynamic_wrongargs_message</b> <i class="arg">arglist</i></a></dt> <dd></dd> <dt><a name="6">proc <b class="cmd">clay::is_dict</b> <i class="arg">d</i></a></dt> <dd></dd> <dt><a name="7">proc <b class="cmd">clay::is_null</b> <i class="arg">value</i></a></dt> <dd></dd> <dt><a name="8">proc <b class="cmd">clay::leaf</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="9">proc <b class="cmd">clay::path</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="10">proc <b class="cmd">clay::script_path</b></a></dt> <dd></dd> <dt><a name="11">proc <b class="cmd">clay::NSNormalize</b> <i class="arg">qualname</i></a></dt> <dd></dd> <dt><a name="12">proc <b class="cmd">clay::uuid_generate</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="13">proc <b class="cmd">clay::dynamic_methods</b> <i class="arg">class</i></a></dt> <dd></dd> <dt><a name="14">proc <b class="cmd">clay::dynamic_methods_class</b> <i class="arg">thisclass</i></a></dt> <dd></dd> <dt><a name="15">proc <b class="cmd">clay::define::Array</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></dt> <dd><p>New OO Keywords for clay</p></dd> <dt><a name="16">proc <b class="cmd">clay::define::component</b> <i class="arg">name</i> <i class="arg">info</i></a></dt> <dd></dd> <dt><a name="17">proc <b class="cmd">clay::define::constructor</b> <i class="arg">arglist</i> <i class="arg">rawbody</i></a></dt> <dd></dd> <dt><a name="18">proc <b class="cmd">clay::define::class_method</b> <i class="arg">name</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt> <dd></dd> <dt><a name="19">proc <b class="cmd">clay::define::clay</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd></dd> <dt><a name="20">proc <b class="cmd">clay::define::destructor</b> <i class="arg">rawbody</i></a></dt> <dd></dd> <dt><a name="21">proc <b class="cmd">clay::define::Dict</b> <i class="arg">name</i> <span class="opt">?<i class="arg">values</i> <b class="const"></b>?</span></a></dt> <dd></dd> <dt><a name="22">proc <b class="cmd">clay::define::Variable</b> <i class="arg">name</i> <span class="opt">?<i class="arg">default</i> <b class="const"></b>?</span></a></dt> <dd><p>This keyword can also be expressed:</p> <pre class="doctools_example">property variable NAME {default DEFAULT}</pre> <p>Variables registered in the variable property are also initialized (if missing) when the object changes class via the <em>morph</em> method.</p></dd> <dt><a name="23">proc <b class="cmd">clay::object_create</b> <i class="arg">objname</i> <span class="opt">?<i class="arg">class</i> <b class="const"></b>?</span></a></dt> <dd></dd> <dt><a name="24">proc <b class="cmd">clay::object_rename</b> <i class="arg">object</i> <i class="arg">newname</i></a></dt> <dd></dd> <dt><a name="25">proc <b class="cmd">clay::object_destroy</b> <i class="arg">objname</i></a></dt> <dd></dd> <dt><a name="26">proc <b class="cmd">clay::ensemble_methodbody</b> <i class="arg">ensemble</i> <i class="arg">einfo</i></a></dt> <dd></dd> <dt><a name="27">proc <b class="cmd">clay::define::Ensemble</b> <i class="arg">rawmethod</i> <i class="arg">arglist</i> <i class="arg">body</i></a></dt> <dd></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">Classes</a></h2> <div id="subsection4" class="doctools_subsection"><h3><a name="subsection4">Class oo::class</a></h3> <p><b class="class">Methods</b></p> <dl class="doctools_definitions"> <dt><a name="28">method <b class="cmd">clay ancestors</b></a></dt> <dd><p>Return this class and all ancestors in search order.</p></dd> <dt><a name="29">method <b class="cmd">clay dump</b></a></dt> <dd><p>Return a complete dump of this object's clay data, but only this object's clay data.</p></dd> <dt><a name="30">method <b class="cmd">clay find</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the clay system. If the last element of <em>path</em> is a branch, returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching leaf and return the first value found. If no value is found, returns an empty string. If a branch is returned the topmost . entry is omitted.</p></dd> <dt><a name="31">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the class's clay system. If no value is found, returns an empty string. If a branch is returned the topmost . entry is omitted.</p></dd> <dt><a name="32">method <b class="cmd">clay GET</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the class's clay system. If no value is found, returns an empty string.</p></dd> <dt><a name="33">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></dt> <dd><p>Recursively merge the dictionaries given into the object's local clay storage.</p></dd> <dt><a name="34">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></dt> <dd><p>Replace the contents of the internal clay storage with the dictionary given.</p></dd> <dt><a name="35">method <b class="cmd">clay search</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Return the first matching value for the path in either this class's clay data or one of its ancestors</p></dd> <dt><a name="36">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></dt> <dd><p>Merge the conents of <b class="const">value</b> with the object's clay storage at <b class="const">path</b>.</p></dd> </dl> </div> <div id="subsection5" class="doctools_subsection"><h3><a name="subsection5">Class oo::object</a></h3> <p><b class="class">Methods</b></p> <dl class="doctools_definitions"> <dt><a name="37">method <b class="cmd">clay ancestors</b></a></dt> <dd><p>Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.</p></dd> <dt><a name="38">method <b class="cmd">clay cget</b> <i class="arg">field</i></a></dt> <dd><p>Pull a value from either the object's clay structure or one of its constituent classes that matches the field name. The order of search us:</p> <p>1. The as a value in local dict variable config</p> <p>2. The as a value in local dict variable clay</p> <p>3. As a leaf in any ancestor as a root of the clay tree</p> <p>4. As a leaf in any ancestor as <b class="const">const</b> <em>field</em></p> <p>5. As a leaf in any ancestor as <b class="const">option</b> <em>field</em> <b class="const">default</b></p></dd> <dt><a name="39">method <b class="cmd">clay delegate</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">object</i>?</span></a></dt> <dd><p>Introspect or control method delegation. With no arguments, the method will return a key/value list of stubs and objects. With just the <i class="arg">stub</i> argument, the method will return the object (if any) attached to the stub. With a <i class="arg">stub</i> and an <i class="arg">object</i> this command will forward all calls to the method <i class="arg">stub</i> to the <i class="arg">object</i>.</p></dd> <dt><a name="40">method <b class="cmd">clay dump</b></a></dt> <dd><p>Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in.</p></dd> <dt><a name="41">method <b class="cmd">clay ensemble_map</b></a></dt> <dd><p>Return a dictionary describing the method ensembles to be assembled for this object</p></dd> <dt><a name="42">method <b class="cmd">clay eval</b> <i class="arg">script</i></a></dt> <dd><p>Evaluated a script in the namespace of this object</p></dd> <dt><a name="43">method <b class="cmd">clay evolve</b></a></dt> <dd><p>Trigger the <b class="method">InitializePublic</b> private method</p></dd> <dt><a name="44">method <b class="cmd">clay exists</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Returns 1 if <em>path</em> exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found.</p></dd> <dt><a name="45">method <b class="cmd">clay flush</b></a></dt> <dd><p>Wipe any caches built by the clay implementation</p></dd> <dt><a name="46">method <b class="cmd">clay forward</b> <i class="arg">method</i> <i class="arg">object</i></a></dt> <dd><p>A convenience wrapper for</p> <pre class="doctools_example">oo::objdefine [self] forward {*}$args</pre> </dd> <dt><a name="47">method <b class="cmd">clay get</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Pull a chunk of data from the clay system. If the last element of <em>path</em> is a branch (ends in a slash /), returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching leaf and return the first value found. If no value is found, returns an empty string.</p></dd> <dt><a name="48">method <b class="cmd">clay leaf</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>A modified get which is tailored to pull only leaf elements</p></dd> <dt><a name="49">method <b class="cmd">clay merge</b> <i class="arg">dict</i> <span class="opt">?<b class="option">dict...</b>?</span></a></dt> <dd><p>Recursively merge the dictionaries given into the object's local clay storage.</p></dd> <dt><a name="50">method <b class="cmd">clay mixin</b> <i class="arg">class</i> <span class="opt">?<b class="option">class...</b>?</span></a></dt> <dd><p>Perform [oo::objdefine [self] mixin] on this object, with a few additional rules: Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.) For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.) Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.)</p></dd> <dt><a name="51">method <b class="cmd">clay mixinmap</b> <span class="opt">?<i class="arg">stub</i>?</span> <span class="opt">?<i class="arg">classes</i>?</span></a></dt> <dd><p>With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given, returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given classes and invoke clay mixin on the new matrix of mixed in classes.</p></dd> <dt><a name="52">method <b class="cmd">clay provenance</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span></a></dt> <dd><p>Return either <b class="const">self</b> if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element.</p></dd> <dt><a name="53">method <b class="cmd">clay replace</b> <i class="arg">dictionary</i></a></dt> <dd><p>Replace the contents of the internal clay storage with the dictionary given.</p></dd> <dt><a name="54">method <b class="cmd">clay source</b> <i class="arg">filename</i></a></dt> <dd><p>Source the given filename within the object's namespace</p></dd> <dt><a name="55">method <b class="cmd">clay set</b> <i class="arg">path</i> <span class="opt">?<b class="option">path...</b>?</span> <i class="arg">value</i></a></dt> <dd><p>Merge the conents of <b class="const">value</b> with the object's clay storage at <b class="const">path</b>.</p></dd> <dt><a name="56">method <b class="cmd">InitializePublic</b></a></dt> <dd><p>Instantiate variables. Called on object creation and during clay mixin.</p></dd> </dl> </div> <div id="subsection6" class="doctools_subsection"><h3><a name="subsection6">Class clay::object</a></h3> <p>clay::object This class is inherited by all classes that have options.</p> <p><b class="class">Methods</b></p> <dl class="doctools_definitions"> <dt><a name="57">method <b class="cmd">InitializePublic</b></a></dt> <dd><p>Instantiate variables and build ensemble methods.</p></dd> </dl> </div> </div> <div id="section4" class="doctools_section"><h2><a name="section4">AUTHORS</a></h2> <p>Sean Woods <a href="mailto:<[email protected]>">mailto:<[email protected]></a></p> </div> <div id="section5" class="doctools_section"><h2><a name="section5">Bugs, Ideas, Feedback</a></h2> <p>This document, and the package it describes, will undoubtedly contain |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/dicttool/dicttool.html.
︙ | ︙ | |||
89 90 91 92 93 94 95 | margin-bottom: 1em; border-bottom: 1px solid black; } --></style> </head> <!-- Generated from file 'dicttool.man' by tcllib/doctools with format 'html' --> | | | | > > > > > > | | | > | > | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | < > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | < < < < < < > > | > > > | | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 | margin-bottom: 1em; border-bottom: 1px solid black; } --></style> </head> <!-- Generated from file 'dicttool.man' by tcllib/doctools with format 'html' --> <!-- Copyright &copy; 2018 Sean Woods &lt;[email protected]&gt; --> <!-- dicttool.n --> <body><hr> [ <a href="../../../../../../../../home">Tcllib Home</a> | <a href="../../../../toc.html">Main Table Of Contents</a> | <a href="../../../toc.html">Table Of Contents</a> | <a href="../../../../index.html">Keyword Index</a> | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">dicttool(n) 1.2 tcllib "Extensions to the standard "dict" command"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> <p>dicttool - Dictionary Tools</p> </div> <div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2> <ul class="doctools_toc"> <li class="doctools_section"><a href="#toc">Table Of Contents</a></li> <li class="doctools_section"><a href="#synopsis">Synopsis</a></li> <li class="doctools_section"><a href="#section1">Description</a></li> <li class="doctools_section"><a href="#section2">Commands</a></li> <li class="doctools_section"><a href="#section3">AUTHORS</a></li> <li class="doctools_section"><a href="#section4">Bugs, Ideas, Feedback</a></li> <li class="doctools_section"><a href="#keywords">Keywords</a></li> <li class="doctools_section"><a href="#category">Category</a></li> <li class="doctools_section"><a href="#copyright">Copyright</a></li> </ul> </div> <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.5</b></li> <li>package require <b class="pkgname">dicttool <span class="opt">?1.0?</span></b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1">proc <b class="cmd"><a href="../../../../index.html#proc">PROC</a></b> <i class="arg">name</i> <i class="arg">arglist</i> <i class="arg">body</i> <span class="opt">?<i class="arg">ninja</i> <b class="const"></b>?</span></a></li> <li><a href="#2">proc <b class="cmd">noop</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#3">proc <b class="cmd">putb</b> <span class="opt">?<i class="arg">map</i>?</span> <i class="arg">text</i></a></li> <li><a href="#4">proc <b class="cmd">tcl::dict::getnull</b> <i class="arg">dictionary</i> <span class="opt">?<i class="arg">element</i>?</span> <span class="opt">?<b class="option">element...</b>?</span></a></li> <li><a href="#5">proc <b class="cmd">tcl::dict::is_dict</b> <i class="arg">d</i></a></li> <li><a href="#6">proc <b class="cmd">dicttool::is_branch</b> <i class="arg">dict</i> <i class="arg">path</i></a></li> <li><a href="#7">proc <b class="cmd">dicttool::print</b> <i class="arg">dict</i></a></li> <li><a href="#8">proc <b class="cmd">dicttool::_dictputb</b> <i class="arg">level</i> <i class="arg">varname</i> <i class="arg">dict</i></a></li> <li><a href="#9">proc <b class="cmd">dicttool::sanitize</b> <i class="arg">dict</i></a></li> <li><a href="#10">proc <b class="cmd">dicttool::_sanitizeb</b> <i class="arg">path</i> <i class="arg">varname</i> <i class="arg">dict</i></a></li> <li><a href="#11">proc <b class="cmd">dicttool::canonical</b> <i class="arg">rawpath</i></a></li> <li><a href="#12">proc <b class="cmd">dicttool::storage</b> <i class="arg">rawpath</i></a></li> <li><a href="#13">proc <b class="cmd">dicttool::dictset</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#14">proc <b class="cmd">dicttool::dictmerge</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#15">proc <b class="cmd">dicttool::merge</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#16">proc <b class="cmd">tcl::dict::isnull</b> <i class="arg">dictionary</i> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#17">proc <b class="cmd">ladd</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">element</i>?</span> <span class="opt">?<b class="option">element...</b>?</span></a></li> <li><a href="#18">proc <b class="cmd">ldelete</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">element</i>?</span> <span class="opt">?<b class="option">element...</b>?</span></a></li> <li><a href="#19">proc <b class="cmd">lrandom</b> <i class="arg">list</i></a></li> </ul> </div> </div> <div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2> <p>The <b class="package">dicttool</b> package enhances the standard <em>dict</em> command with several new commands. In addition, the package also defines several "creature comfort" list commands as well. Each command checks to see if a command already exists of the same name before adding itself, just in case any of these slip into the core.</p> </div> <div id="section2" class="doctools_section"><h2><a name="section2">Commands</a></h2> <dl class="doctools_definitions"> <dt><a name="1"><b class="cmd">ladd</b> <i class="arg">varname</i> <i class="arg">args</i></a></dt> <dd><p>This command will add a new instance of each element in <i class="arg">args</i> to <i class="arg">varname</i>, but only if that element is not already present.</p></dd> <dt><a name="2"><b class="cmd">ldelete</b> <i class="arg">varname</i> <i class="arg">args</i></a></dt> <dd><p>This command will delete all instances of each element in <i class="arg">args</i> from <i class="arg">varname</i>.</p></dd> <dt><a name="3"><b class="cmd">dict getnull</b> <i class="arg">args</i></a></dt> <dd><p>Operates like <b class="cmd">dict get</b>, however if the key <i class="arg">args</i> does not exist, it returns an empty list instead of throwing an error.</p></dd> <dt><a name="4"><b class="cmd">dict print</b> <i class="arg">dict</i></a></dt> <dd><p>This command will produce a string representation of <i class="arg">dict</i>, with each nested branch on a newline, and indented with two spaces for every level.</p></dd> <dt><a name="5"><b class="cmd">dict is_dict</b> <i class="arg">value</i></a></dt> <dd><p>This command will return true if <i class="arg">value</i> can be interpreted as a dict. The command operates in such a way as to not force an existing dict representation to shimmer into another internal rep.</p></dd> <dt><a name="6"><b class="cmd">rmerge</b> <i class="arg">args</i></a></dt> <dd><p>Return a dict which is the product of a recursive merge of all of the arguments. Unlike <b class="cmd">dict merge</b>, this command descends into all of the levels of a dict. Dict keys which end in a : indicate a leaf, which will be interpreted as a literal value, and not descended into further.</p> <pre class="doctools_example"> if {[dict exists $dictionary {*}$args]} { return [dict get $dictionary {*}$args] } else { return {} } </pre> <p>Example:</p> <pre class="doctools_example"> set value [dict getnull $arglist $option] </pre> </dd> <dt><a name="5">proc <b class="cmd">tcl::dict::is_dict</b> <i class="arg">d</i></a></dt> <dd><p>Test if value is a dict.</p> <p>This command is added to the <b class="function">dict</b> ensemble as <b class="function">dict is_dict</b></p></dd> <dt><a name="6">proc <b class="cmd">dicttool::is_branch</b> <i class="arg">dict</i> <i class="arg">path</i></a></dt> <dd><p>Return true if the element with the value is a dict. is given as a list to descend into sub-dicts of the current dict. The rules are as follows:</p> <ol class="doctools_enumerated"> <li><p>If the last character of the last element of is a colon (:) return false</p></li> <li><p>If the last character of the last element of is a slash (/) return true</p></li> <li><p>If a sub-element if named <b class="const">.info</b> is present return true</p></li> </ol> <p>This command is added to the <b class="function">dict</b> ensemble as <b class="function">dicttool::is_branch</b></p> <p>Example:</p> <pre class="doctools_example"> > set mydict {sub/ {sub/ {field {A block of text}}} > dicttool::is_branch $mydict sub/ 1 > dicttool::is_branch $mydict {sub/ sub/} 1 > dicttool::is_branch $mydict {sub/ sub/ field} 0 </pre> </dd> <dt><a name="7">proc <b class="cmd">dicttool::print</b> <i class="arg">dict</i></a></dt> <dd><p>Output a dictionary as an indented stream of data suitable for output to the screen. The system uses the rules for <b class="function">dicttool::is_branch</b> to determine if an value in a dictionary is a leaf or a branch.</p> <p>Example:</p> <pre class="doctools_example"> > set mydict {sub/ {sub/ {field {A block of text}}} > dicttool::print $mydict sub/ { sub/ { field {A block of text} } } </pre> </dd> <dt><a name="8">proc <b class="cmd">dicttool::_dictputb</b> <i class="arg">level</i> <i class="arg">varname</i> <i class="arg">dict</i></a></dt> <dd><p>Helper function for ::dicttool::print Formats the string representation for a dictionary element within a human readable stream of lines, and determines if it needs to call itself with further indentation to express a sub-branch</p></dd> <dt><a name="9">proc <b class="cmd">dicttool::sanitize</b> <i class="arg">dict</i></a></dt> <dd><p>Output a dictionary removing any . entries added by <b class="function">dicttool::merge</b></p></dd> <dt><a name="10">proc <b class="cmd">dicttool::_sanitizeb</b> <i class="arg">path</i> <i class="arg">varname</i> <i class="arg">dict</i></a></dt> <dd><p>Helper function for ::dicttool::sanitize Formats the string representation for a dictionary element within a human readable stream of lines, and determines if it needs to call itself with further indentation to express a sub-branch</p></dd> <dt><a name="11">proc <b class="cmd">dicttool::canonical</b> <i class="arg">rawpath</i></a></dt> <dd><p>Return the path as a canonical path for dicttool with all branch keys ending in a / and the final element ending in a / if the final element in the path ended in a / This command will also break arguments up if they contain /.</p> <p>Example:</p> <pre class="doctools_example"> > dicttool::canonical foo bar baz bang foo/ bar/ baz/ bang > dicttool::canonical foo bar baz bang/ foo/ bar/ baz/ bang/ > dicttool::canonical foo bar baz bang: foo/ bar/ baz/ bang > dicttool::canonical foo/bar/baz bang: foo/ bar/ baz/ bang > dicttool::canonical foo/bar/baz/bang foo/ bar/ baz/ bang </pre> </dd> <dt><a name="12">proc <b class="cmd">dicttool::storage</b> <i class="arg">rawpath</i></a></dt> <dd><p>Return the path as a storage path for dicttool with all branch terminators removed. This command will also break arguments up if they contain /.</p> <p>Example:</p> <pre class="doctools_example"> > dicttool::storage foo bar baz bang foo bar baz bang > dicttool::storage foo bar baz bang/ foo bar baz bang > dicttool::storage foo bar baz bang: foo bar baz bang > dicttool::storage foo/bar/baz bang: foo bar baz bang > dicttool::storage foo/bar/baz/bang foo bar baz bang </pre> </dd> <dt><a name="13">proc <b class="cmd">dicttool::dictset</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd><p>Set an element with a recursive dictionary, marking all branches on the way down to the final element. If the value does not exists in the nested dictionary it is added as a leaf. If the value already exists as a branch the value given is merged if the value is a valid dict. If the incoming value is not a valid dict, the value overrides the value stored, and the value is treated as a leaf from then on.</p> <p>Example:</p> <pre class="doctools_example"> > set r {} > ::dicttool::dictset r option color default Green . 1 option {. 1 color {. 1 default Green}} > ::dicttool::dictset r option {Something not dictlike} . 1 option {Something not dictlike} # Note that if the value is not a dict, and you try to force it to be # an error with be thrown on the merge > ::dicttool::dictset r option color default Blue missing value to go with key </pre> </dd> <dt><a name="14">proc <b class="cmd">dicttool::dictmerge</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd><p>A recursive form of dict merge, intended for modifying variables in place.</p> <p>Example:</p> <pre class="doctools_example"> > set mydict {sub/ {sub/ {description {a block of text}}}} > ::dicttool::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}] > dicttool::print $mydict sub/ { sub/ { description {a block of text} field {another block of text} } } </pre> </dd> <dt><a name="15">proc <b class="cmd">dicttool::merge</b> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd><p>A recursive form of dict merge</p> <p>A routine to recursively dig through dicts and merge adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/</p> <p>Example:</p> <pre class="doctools_example"> > set mydict {sub/ {sub/ {description {a block of text}}}} > set odict [dicttool::merge $mydict {sub/ {sub/ {field {another block of text}}}}] > dicttool::print $odict sub/ { sub/ { description {a block of text} field {another block of text} } } </pre> </dd> <dt><a name="16">proc <b class="cmd">tcl::dict::isnull</b> <i class="arg">dictionary</i> <span class="opt">?<i class="arg">args</i>?</span></a></dt> <dd><p>Returns true if the path specified by args either does not exist, if exists and contains an empty string or the value of NULL or null.</p> <p>This function is added to the global dict ensemble as <b class="function">dict isnull</b></p></dd> <dt><a name="17">proc <b class="cmd">ladd</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">element</i>?</span> <span class="opt">?<b class="option">element...</b>?</span></a></dt> <dd><p>Add elements to a list if that are not already present in the list. As a side effect, if variable does not exists, create it as an empty list.</p> <p>Example:</p> <pre class="doctools_example"> ladd contents foo bar puts $contents > foo bar ladd contents foo bar baz bang puts $contents > foo bar baz bang </pre> </dd> <dt><a name="18">proc <b class="cmd">ldelete</b> <i class="arg">varname</i> <span class="opt">?<i class="arg">element</i>?</span> <span class="opt">?<b class="option">element...</b>?</span></a></dt> <dd><p>Delete all instances of the elements given from a list contained in . If the variable does exist this is a noop.</p> <p>Example:</p> <pre class="doctools_example"> set contents {foo bar baz bang foo foo foo} ldelete contents foo puts $contents > bar baz bang </pre> </dd> <dt><a name="19">proc <b class="cmd">lrandom</b> <i class="arg">list</i></a></dt> <dd><p>Return a random element from</p></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">AUTHORS</a></h2> <p>Sean Woods <a href="mailto:<[email protected]>">mailto:<[email protected]></a></p> </div> <div id="section4" class="doctools_section"><h2><a name="section4">Bugs, Ideas, Feedback</a></h2> <p>This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category <em>dict</em> of the <a href="http://core.tcl.tk/tcllib/reportlist">Tcllib Trackers</a>. Please also report any ideas for enhancements you may have for either package and/or documentation.</p> <p>When proposing code changes, please provide <em>unified diffs</em>, i.e the output of <b class="const">diff -u</b>.</p> <p>Note further that <em>attachments</em> are strongly preferred over inlined patches. Attachments can be made by going to the <b class="const">Edit</b> form of the ticket immediately after its creation, and then using the left-most button in the secondary navigation bar.</p> </div> <div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2> <p><a href="../../../../index.html#dict">dict</a></p> </div> <div id="category" class="doctools_section"><h2><a name="category">Category</a></h2> <p>Utilities</p> </div> <div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2> <p>Copyright © 2018 Sean Woods <[email protected]></p> </div> </div></body></html> |
Changes to idoc/www/tcllib/files/modules/fumagic/cfront.html.
︙ | ︙ | |||
143 144 145 146 147 148 149 | into recognizers based on the <b class="package"><a href="rtcore.html">fileutil::magic::rt</a></b> recognizer runtime package. For the generator backed used by this compiler see the package <b class="package"><a href="cgen.html">fileutil::magic::cgen</a></b>.</p> </div> <div id="section2" class="doctools_section"><h2><a name="section2">COMMANDS</a></h2> <dl class="doctools_definitions"> <dt><a name="1"><b class="cmd">::fileutil::magic::cfront::compile</b> <i class="arg">path</i>...</a></dt> | | | | > > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | into recognizers based on the <b class="package"><a href="rtcore.html">fileutil::magic::rt</a></b> recognizer runtime package. For the generator backed used by this compiler see the package <b class="package"><a href="cgen.html">fileutil::magic::cgen</a></b>.</p> </div> <div id="section2" class="doctools_section"><h2><a name="section2">COMMANDS</a></h2> <dl class="doctools_definitions"> <dt><a name="1"><b class="cmd">::fileutil::magic::cfront::compile</b> <i class="arg">path</i>...</a></dt> <dd><p>This command takes the paths of one or more files and directories and compiles all the files, and the files in all the directories into a single analyzer for all the file types specified in these files. It returns a list whose first item is a list per-file dictionaries of analyzer scripts and whose second item is a list of analyzer commands.</p> <p>All the files have to be in the format specified by magic(5).</p> <p>The result of the command is a Tcl script containing the generated recognizer.</p></dd> <dt><a name="2"><b class="cmd">::fileutil::magic::cfront::procdef</b> <i class="arg">procname</i> <i class="arg">path</i>...</a></dt> <dd><p>This command behaves like <b class="cmd">::fileutil::magic::cfront::compile</b> with regard to the specified path arguments, then wraps the resulting recognizer script into a procedure named <i class="arg">procname</i>, puts code |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/fumagic/rtcore.html.
︙ | ︙ | |||
127 128 129 130 131 132 133 | <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.5</b></li> <li>package require <b class="pkgname">fileutil::magic::rt <span class="opt">?2.0?</span></b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1"><b class="cmd">::fileutil::magic::rt::></b></a></li> <li><a href="#2"><b class="cmd">::fileutil::magic::rt::<</b></a></li> | | | | | | | | < | < < < < | | | | < | < | | | | | | | | < | | | < < < < < | < < < < < < < < < < < < | > > > | | | < | < < | < < < < < < | | < > | | < | | | < < < < < | | < < < < < < < | < < < < < | | | < < < < | | | | < < < | | | | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.5</b></li> <li>package require <b class="pkgname">fileutil::magic::rt <span class="opt">?2.0?</span></b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1"><b class="cmd">::fileutil::magic::rt::></b></a></li> <li><a href="#2"><b class="cmd">::fileutil::magic::rt::<</b></a></li> <li><a href="#3"><b class="cmd">::fileutil::magic::rt::new</b> <i class="arg">chan</i> <i class="arg">named</i> <i class="arg">analyze</i></a></li> <li><a href="#4"><b class="cmd">::fileutil::magic::rt::file_start</b> <i class="arg">name</i></a></li> <li><a href="#5"><b class="cmd">::fileutil::magic::rt::emit</b> <i class="arg">msg</i></a></li> <li><a href="#6"><b class="cmd">::fileutil::magic::rt::O</b> <i class="arg">where</i></a></li> <li><a href="#7"><b class="cmd">::fileutil::magic::rt::R</b> <i class="arg">where</i></a></li> <li><a href="#8"><b class="cmd">::fileutil::magic::rt::Nv</b> <i class="arg">type</i> <i class="arg">offset</i> <i class="arg">compinvert</i> <i class="arg">comp</i> <i class="arg">expected</i></a></li> <li><a href="#9"><b class="cmd">::fileutil::magic::rt::N</b> <i class="arg">type</i> <i class="arg">offset</i> <i class="arg">testinvert</i> <i class="arg">compinvert</i> <i class="arg">mod</i> <i class="arg">mand</i> <i class="arg">comp</i> <i class="arg">expected</i></a></li> <li><a href="#10"><b class="cmd">::fileutil::magic::rt::S</b> <i class="arg">type</i> <i class="arg">offset</i> <i class="arg">testinvert</i> <i class="arg">mod</i> <i class="arg">mand</i> <i class="arg">comp</i> <i class="arg">val</i></a></li> <li><a href="#11"><b class="cmd">::fileutil::magic::rt::L</b> <i class="arg">newlevel</i></a></li> <li><a href="#12"><b class="cmd">::fileutil::magic::rt::I</b> <i class="arg">offset</i> <i class="arg">it</i> <i class="arg">ioi</i> <i class="arg">ioo</i> <i class="arg">iir</i> <i class="arg">io</i></a></li> <li><a href="#13"><b class="cmd">::fileutil::magic::rt::R</b> <i class="arg">offset</i></a></li> <li><a href="#14"><b class="cmd">::fileutil::magic::rt::U</b> <i class="arg">fileindex</i> <i class="arg">name</i></a></li> </ul> </div> </div> <div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2> <p>This package provides the runtime core for file type recognition engines written in pure Tcl and is thus used by all other packages in this module such as <b class="package"><a href="filetypes.html">fileutil::magic::filetype</a></b> and the two compiler packages <b class="package"><a href="cgen.html">fileutil::magic::cgen</a></b> and <b class="package"><a href="cfront.html">fileutil::magic::cfront</a></b>.</p> </div> <div id="section2" class="doctools_section"><h2><a name="section2">COMMANDS</a></h2> <dl class="doctools_definitions"> <dt><a name="1"><b class="cmd">::fileutil::magic::rt::></b></a></dt> <dd><p>Increment the level and perform related housekeeping</p></dd> <dt><a name="2"><b class="cmd">::fileutil::magic::rt::<</b></a></dt> <dd><p>Decrement the level and perform related housekeeping</p></dd> <dt><a name="3"><b class="cmd">::fileutil::magic::rt::new</b> <i class="arg">chan</i> <i class="arg">named</i> <i class="arg">analyze</i></a></dt> <dd><p>Create a new command which returns one description of the file each time it is called, and a code of <i class="arg">break</i> when there are no more descriptions. <i class="arg">chan</i> is the channel containing the data to describe. The channel configuration is then managed as needed. <i class="arg">named</i> is a dictionary of named tests, as generated by <b class="cmd">fileutil::magic::cfront::compile</b>. <i class="arg">test</i> is a command prefix for a routine composed of the list of commands as returned by <b class="cmd">fileutil::magic::cfront::compile</b>.</p></dd> <dt><a name="4"><b class="cmd">::fileutil::magic::rt::file_start</b> <i class="arg">name</i></a></dt> <dd><p>This command marks the start of a magic file when debugging. It returns the empty string as its result.</p></dd> <dt><a name="5"><b class="cmd">::fileutil::magic::rt::emit</b> <i class="arg">msg</i></a></dt> <dd><p>This command adds the text <i class="arg">msg</i> to the result buffer. The message may contain the following special character sequences. They will be replaced with buffered values before the message is added to the result. The command returns the empty string as its result.</p> <dl class="doctools_definitions"> <dt><b class="const">\b</b></dt> <dd><p>This sequence is removed</p></dd> <dt><b class="const">%s</b></dt> <dd><p>Replaced with the last buffered string value.</p></dd> <dt><b class="const">%ld</b></dt> <dd><p>Replaced with the last buffered numeric value.</p></dd> <dt><b class="const">%d</b></dt> <dd><p>See above.</p></dd> <dt><b class="const">${x:...?...}</b></dt> <dd><p>Substitute one string if the file is executable, and another string otherwise.</p></dd> </dl></dd> <dt><a name="6"><b class="cmd">::fileutil::magic::rt::O</b> <i class="arg">where</i></a></dt> <dd><p>Produce an offset from <i class="arg">where</i>, relative to the cursor one level up. Produce an offset from <i class="arg">where</i>, relative to the offset one level up.</p></dd> <dt><a name="8"><b class="cmd">::fileutil::magic::rt::Nv</b> <i class="arg">type</i> <i class="arg">offset</i> <i class="arg">compinvert</i> <i class="arg">comp</i> <i class="arg">expected</i></a></dt> <dd><p>A limited form of <b class="cmd">::fileutile::magic::rt::N</b> that only checks for equality and can't be told to invert the test.</p></dd> <dt><a name="9"><b class="cmd">::fileutil::magic::rt::N</b> <i class="arg">type</i> <i class="arg">offset</i> <i class="arg">testinvert</i> <i class="arg">compinvert</i> <i class="arg">mod</i> <i class="arg">mand</i> <i class="arg">comp</i> <i class="arg">expected</i></a></dt> <dd><p>Fetch the numeric value with <i class="arg">type</i> from the absolute location <i class="arg">offset</i>, compare it with <i class="arg">expected</i> using <i class="arg">comp</i> as the comparision operator, and returns the result.</p> <p>The argument <i class="arg">comp</i> must be one of Tcl's comparison operators.</p> <pre class="doctools_example"> <comp> <fetched-and-masked-value> <comp> <expected> </pre> <p>The special comparison operator <b class="const">x</b> signals that no comparison should be done, or, in other words, that the fetched value will always match <i class="arg">val</i>.</p></dd> <dt><a name="10"><b class="cmd">::fileutil::magic::rt::S</b> <i class="arg">type</i> <i class="arg">offset</i> <i class="arg">testinvert</i> <i class="arg">mod</i> <i class="arg">mand</i> <i class="arg">comp</i> <i class="arg">val</i></a></dt> <dd><p>Like <b class="cmd">::fileutil::magic::rt::N</b> except that it fetches and compares string types , not numeric data.</p></dd> <dt><a name="11"><b class="cmd">::fileutil::magic::rt::L</b> <i class="arg">newlevel</i></a></dt> <dd><p>Sets the current level in the calling context to <i class="arg">newlevel</i>. The command returns the empty string as its result.</p></dd> <dt><a name="12"><b class="cmd">::fileutil::magic::rt::I</b> <i class="arg">offset</i> <i class="arg">it</i> <i class="arg">ioi</i> <i class="arg">ioo</i> <i class="arg">iir</i> <i class="arg">io</i></a></dt> <dd><p>Calculates an offset based on an initial offset and the provided modifiers.</p></dd> <dt><a name="13"><b class="cmd">::fileutil::magic::rt::R</b> <i class="arg">offset</i></a></dt> <dd><p>Given an initial offset, calculates an offset relative to the cursor at the next level up. The cursor is the position in the data one character after the data extracted from the file one level up.</p></dd> <dt><a name="14"><b class="cmd">::fileutil::magic::rt::U</b> <i class="arg">fileindex</i> <i class="arg">name</i></a></dt> <dd><p>Add a level and use a named test script.</p></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">NUMERIC TYPES</a></h2> <dl class="doctools_definitions"> <dt><b class="const">byte</b></dt> <dd><p>8-bit integer</p></dd> <dt><b class="const">short</b></dt> |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/math/numtheory.html.
1 2 3 4 5 6 7 | <!DOCTYPE html><html><head> <title>math::numtheory - Tcl Math Library</title> <style type="text/css"><!-- HTML { background: #FFFFFF; color: black; } | > | 1 2 3 4 5 6 7 8 | <!DOCTYPE html><html><head> <title>math::numtheory - Tcl Math Library</title> <style type="text/css"><!-- HTML { background: #FFFFFF; color: black; } |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/math/statistics.html.
︙ | ︙ | |||
854 855 856 857 858 859 860 861 862 863 864 865 866 867 | logistic model.</p> <dl class="doctools_arguments"> <dt>list <i class="arg">coeffs</i></dt> <dd><p>List of coefficients as determine by the <b class="cmd">logistic-model</b> command</p></dd> <dt>float <i class="arg">x</i></dt> <dd><p>X-value for which the probability needs to be determined</p></dd> </dl></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">MULTIVARIATE LINEAR REGRESSION</a></h2> <p>Besides the linear regression with a single independent variable, the statistics package provides two procedures for doing ordinary least squares (OLS) and weighted least squares (WLS) linear regression with several variables. They were written by Eric Kemp-Benedict.</p> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 | logistic model.</p> <dl class="doctools_arguments"> <dt>list <i class="arg">coeffs</i></dt> <dd><p>List of coefficients as determine by the <b class="cmd">logistic-model</b> command</p></dd> <dt>float <i class="arg">x</i></dt> <dd><p>X-value for which the probability needs to be determined</p></dd> </dl></dd> <dt><a name="44"><b class="cmd">::math::statistics::wasserstein-distance</b> <i class="arg">prob1</i> <i class="arg">prob2</i></a></dt> <dd><p>Compute the Wasserstein distance or earth mover's distance for two equidstantly spaced histograms or probability densities. The histograms need not to be normalised to sum to one, but they must have the same number of entries.</p> <p>Note: the histograms are assumed to be based on the same equidistant intervals. As the bounds are not passed, the value is expressed in the length of the intervals.</p> <dl class="doctools_arguments"> <dt>list <i class="arg">prob1</i></dt> <dd><p>List of values for the first histogram/probability density</p></dd> <dt>list <i class="arg">prob2</i></dt> <dd><p>List of values for the second histogram/probability density</p></dd> </dl></dd> <dt><a name="45"><b class="cmd">::math::statistics::kl-divergence</b> <i class="arg">prob1</i> <i class="arg">prob2</i></a></dt> <dd><p>Compute the Kullback-Leibler (KL) divergence for two equidstantly spaced histograms or probability densities. The histograms need not to be normalised to sum to one, but they must have the same number of entries.</p> <p>Note: the histograms are assumed to be based on the same equidistant intervals. As the bounds are not passed, the value is expressed in the length of the intervals.</p> <p>Note also that the KL divergence is not symmetric and that the second histogram should not contain zeroes in places where the first histogram has non-zero values.</p> <dl class="doctools_arguments"> <dt>list <i class="arg">prob1</i></dt> <dd><p>List of values for the first histogram/probability density</p></dd> <dt>list <i class="arg">prob2</i></dt> <dd><p>List of values for the second histogram/probability density</p></dd> </dl></dd> <dt><a name="46"><b class="cmd">::math::statistics::logistic-model</b> <i class="arg">xdata</i> <i class="arg">ydata</i></a></dt> <dd><p>Estimate the coefficients of the logistic model that fits the data best. The data consist of independent x-values and the outcome 0 or 1 for each of the x-values. The result can be used to estimate the probability that a certain x-value gives 1.</p> <dl class="doctools_arguments"> <dt>list <i class="arg">xdata</i></dt> <dd><p>List of values for which the success (1) or failure (0) is known</p></dd> <dt>list <i class="arg">ydata</i></dt> <dd><p>List of successes or failures corresponding to each value in <i class="term">xdata</i>.</p></dd> </dl></dd> <dt><a name="47"><b class="cmd">::math::statistics::logistic-probability</b> <i class="arg">coeffs</i> <i class="arg">x</i></a></dt> <dd><p>Calculate the probability of success for the value <i class="term">x</i> given the coefficients of the logistic model.</p> <dl class="doctools_arguments"> <dt>list <i class="arg">coeffs</i></dt> <dd><p>List of coefficients as determine by the <b class="cmd">logistic-model</b> command</p></dd> <dt>float <i class="arg">x</i></dt> <dd><p>X-value for which the probability needs to be determined</p></dd> </dl></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">MULTIVARIATE LINEAR REGRESSION</a></h2> <p>Besides the linear regression with a single independent variable, the statistics package provides two procedures for doing ordinary least squares (OLS) and weighted least squares (WLS) linear regression with several variables. They were written by Eric Kemp-Benedict.</p> |
︙ | ︙ | |||
1016 1017 1018 1019 1020 1021 1022 | <dt><a name="55"><b class="cmd">::math::statistics::pdf-exponential</b> <i class="arg">mean</i> <i class="arg">value</i></a></dt> <dd><p>Return the probability of a given value for an exponential distribution with given mean.</p> <dl class="doctools_arguments"> <dt>float <i class="arg">mean</i></dt> <dd><p>- Mean value of the distribution</p></dd> <dt>float <i class="arg">value</i></dt> | < < < | 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 | <dt><a name="55"><b class="cmd">::math::statistics::pdf-exponential</b> <i class="arg">mean</i> <i class="arg">value</i></a></dt> <dd><p>Return the probability of a given value for an exponential distribution with given mean.</p> <dl class="doctools_arguments"> <dt>float <i class="arg">mean</i></dt> <dd><p>- Mean value of the distribution</p></dd> <dt>float <i class="arg">value</i></dt> <dt><a name="56"><b class="cmd">::math::statistics::pdf-uniform</b> <i class="arg">xmin</i> <i class="arg">xmax</i> <i class="arg">value</i></a></dt> <dd><p>Return the probability of a given value for a uniform distribution with given extremes.</p> <dl class="doctools_arguments"> <dt>float <i class="arg">xmin</i></dt> <dd><p>- Minimum value of the distribution</p></dd> <dt>float <i class="arg">xmin</i></dt> <dd><p>- Maximum value of the distribution</p></dd> <dt>float <i class="arg">value</i></dt> <dd><p>- Value for which the probability is required</p></dd> <dt><a name="57"><b class="cmd">::math::statistics::pdf-triangular</b> <i class="arg">xmin</i> <i class="arg">xmax</i> <i class="arg">value</i></a></dt> <dd><p>Return the probability of a given value for a triangular distribution with given extremes. If the argument min is lower than the argument max, then smaller values have higher probability and vice versa. In the first case the probability density function is of the form <em>f(x) = 2(1-x)</em> and the other case it is of the form <em>f(x) = 2x</em>.</p> <dl class="doctools_arguments"> <dt>float <i class="arg">xmin</i></dt> |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/math/trig.html.
1 2 3 4 5 6 7 | <!DOCTYPE html><html><head> <title>math::trig - Tcl Math Library</title> <style type="text/css"><!-- HTML { background: #FFFFFF; color: black; } | > | 1 2 3 4 5 6 7 8 | <!DOCTYPE html><html><head> <title>math::trig - Tcl Math Library</title> <style type="text/css"><!-- HTML { background: #FFFFFF; color: black; } |
︙ | ︙ | |||
95 96 97 98 99 100 101 | --> <!-- Copyright &copy; 2018 Arjen Markus --> <!-- math::trig.n --> <body><hr> [ <a href="../../../../../../../../home">Tcllib Home</a> | | | | | | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | --> <!-- Copyright &copy; 2018 Arjen Markus --> <!-- math::trig.n --> <body><hr> [ <a href="../../../../../../../../home">Tcllib Home</a> | <a href="../../../../toc.html">Main Table Of Contents</a> | <a href="../../../toc.html">Table Of Contents</a> | <a href="../../../../index.html">Keyword Index</a> | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">math::trig(n) 1.0.0 tcllib "Tcl Math Library"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> <p>math::trig - Trigonometric anf hyperbolic functions</p> </div> <div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2> |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/mime/mime.html.
︙ | ︙ | |||
105 106 107 108 109 110 111 | | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">mime(n) 1.6.3 tcllib "Mime"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | | <a href="../../../../toc0.html">Categories</a> | <a href="../../../../toc1.html">Modules</a> | <a href="../../../../toc2.html">Applications</a> ] <hr> <div class="doctools"> <h1 class="doctools_title">mime(n) 1.6.3 tcllib "Mime"</h1> <div id="name" class="doctools_section"><h2><a name="name">Name</a></h2> <p>mime - Manipulation of Internet messages</p> </div> <div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2> <ul class="doctools_toc"> <li class="doctools_section"><a href="#toc">Table Of Contents</a></li> <li class="doctools_section"><a href="#synopsis">Synopsis</a></li> <li class="doctools_section"><a href="#section1">Description</a></li> <li class="doctools_section"><a href="#section2">KNOWN BUGS</a></li> |
︙ | ︙ | |||
127 128 129 130 131 132 133 | <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.5</b></li> <li>package require <b class="pkgname">mime <span class="opt">?1.6.3?</span></b></li> </ul> <ul class="doctools_syntax"> | | > > | | | < < | | | | | < | < < < < | < > | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < | < < | < < < < < < < | < < > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < | | 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 170 171 172 173 174 175 176 | <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">Tcl 8.5</b></li> <li>package require <b class="pkgname">mime <span class="opt">?1.6.3?</span></b></li> </ul> <ul class="doctools_syntax"> <li><a href="#1"><b class="cmd">::mime::initialize</b> <span class="opt">?<b class="option">-canonical</b> <i class="arg">type/subtype</i>?</span> <span class="opt">?<b class="option">-params</b> <i class="arg">dictionary</i>?</span> <span class="opt">?<b class="option">-encoding</b> <i class="arg">value</i>?</span> <span class="opt">?<b class="option">-headers</b> <i class="arg">dictionary</i>?</span> <span class="opt">?(<b class="option">-chan</b> <i class="arg">name</i> | <b class="option">-file</b> <i class="arg">name</i> | <b class="option">-string</b> <i class="arg">value</i> | <b class="option">-parts</b> <i class="arg">parts</i>)?</span></a></li> <li><a href="#2"><b class="cmd">::mime::body</b> <i class="arg">token</i> <span class="opt">?<b class="option">-decode</b>?</span> <span class="opt">?<b class="option">-blocksize</b> <i class="arg">octets</i>?</span>"</a></li> <li><a href="#3"><b class="cmd">::mime::datetime</b> (<i class="arg">time</i> | <b class="option">-now</b>) <i class="arg">property</i></a></li> <li><a href="#4"><b class="cmd">::mime::finalize</b> <i class="arg">token</i> <span class="opt">?<b class="option">-subordinates</b> <b class="const">all</b> | <b class="const">dynamic</b> | <b class="const">none</b>?</span></a></li> <li><a href="#5"><b class="cmd">::mime::header</b> <b class="cmd">serialize</b> <i class="arg">value</i> <i class="arg">parameters</i></a></li> <li><a href="#6"><b class="cmd">::mime::header</b> <b class="cmd">get</b> <i class="arg">token</i> <span class="opt">?<i class="arg">key</i> | <b class="option">-names</b>?</span></a></li> <li><a href="#7"><b class="cmd">::mime::header</b> <b class="cmd"><a href="../../../../index.html#set">set</a></b> <i class="arg">token</i> <i class="arg">name value</i> <span class="opt">?<i class="arg">parameters</i> <span class="opt">?<b class="option">-mode</b> <b class="const">write</b> | <b class="const">append</b> | <b class="const">delete</b>?</span>?</span></a></li> <li><a href="#8"><b class="cmd">::mime::property</b> <i class="arg">token</i> <span class="opt">?<i class="arg">name</i> | <b class="option">-names</b>?</span></a></li> <li><a href="#9"><b class="cmd">::mime::serialize</b> <i class="arg">token</i> <span class="opt">?<b class="option">-chan</b> <i class="arg">channel</i>?</span></a></li> <li><a href="#10"><b class="cmd">::mime::parseaddress</b> <i class="arg">addresses</i></a></li> <li><a href="#11"><b class="cmd">::mime::mapencoding</b> <i class="arg">encoding_name</i></a></li> <li><a href="#12"><b class="cmd">::mime::reversemapencoding</b> <i class="arg">charset_type</i></a></li> </ul> </div> </div> <div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2> <p>Provides commands to create and manipulate Internet messages.</p> <dl class="doctools_definitions"> <dt><a name="1"><b class="cmd">::mime::initialize</b> <span class="opt">?<b class="option">-canonical</b> <i class="arg">type/subtype</i>?</span> <span class="opt">?<b class="option">-params</b> <i class="arg">dictionary</i>?</span> <span class="opt">?<b class="option">-encoding</b> <i class="arg">value</i>?</span> <span class="opt">?<b class="option">-headers</b> <i class="arg">dictionary</i>?</span> <span class="opt">?(<b class="option">-chan</b> <i class="arg">name</i> | <b class="option">-file</b> <i class="arg">name</i> | <b class="option">-string</b> <i class="arg">value</i> | <b class="option">-parts</b> <i class="arg">parts</i>)?</span></a></dt> <dd><p>Parses a message and returns a token for the message. One of <b class="option">-chan</b>, <b class="option">-file</b>, or <b class="option">-string</b> must be provided as the source of the input. If <b class="option">-canonical</b> is provided the input is the body only and is already formatted according to the provided <i class="arg">type/subtype</i>, and therefore should not be parsed. If <i class="arg">parts</i> is provided it is a list of tokens for messages that comprise a <b class="const">multipart/mixed</b> message body. <b class="option">-params</b> is a multidict (a dictionary where the keys may not be unique) of parameters for the <b class="const">Content-Type</b> header. <b class="option">-headers</b> is a multidict of headers.</p> <p><b class="option">-encoding</b> sets the <b class="const">Content-Transfer-Encoding</b>.</p></dd> <dt><a name="2"><b class="cmd">::mime::body</b> <i class="arg">token</i> <span class="opt">?<b class="option">-decode</b>?</span> <span class="opt">?<b class="option">-blocksize</b> <i class="arg">octets</i>?</span>"</a></dt> <dd><p>Returns as a string in canonical form the body of the message corresponding to <i class="arg">token</i>.</p> <p>If <b class="option">-blocksize</b> is provided, returns a command that itself returns up to the next <i class="arg">octets</i> of the message each time it's called, and returns a code of <b class="const">break</b> when finished, deleting itself as well. If <i class="arg">octets</i> is the empty string, a default value is used. Pauses the current coroutine as needed to wait for input.</p> <p><b class="option">-decode</b> converts the message body from the character set it is encoded in.</p></dd> <dt><a name="3"><b class="cmd">::mime::datetime</b> (<i class="arg">time</i> | <b class="option">-now</b>) <i class="arg">property</i></a></dt> <dd><p>Returns the <i class="arg">property</i> of <i class="arg">time</i>, which 822-style date-time value.</p> <p>Available properties and their ranges are:</p> <dl class="doctools_definitions"> <dt><b class="const">hour</b></dt> <dd><p>0 .. 23</p></dd> <dt><b class="const">lmonth</b></dt> <dd><p>January, February, ..., December</p></dd> <dt><b class="const">lweekday</b></dt> <dd><p>Sunday, Monday, ... Saturday</p></dd> |
︙ | ︙ | |||
321 322 323 324 325 326 327 328 329 | <dd><p>Sun, Mon, ..., Sat</p></dd> <dt><b class="const">yday</b></dt> <dd><p>1 .. 366</p></dd> <dt><b class="const">year</b></dt> <dd><p>1900 ...</p></dd> <dt><b class="const">zone</b></dt> <dd><p>-720 .. 720 (minutes east of GMT)</p></dd> </dl></dd> <dt><a name="11"><b class="cmd">::mime::mapencoding</b> <i class="arg">encoding_name</i></a></dt> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | <dd><p>Sun, Mon, ..., Sat</p></dd> <dt><b class="const">yday</b></dt> <dd><p>1 .. 366</p></dd> <dt><b class="const">year</b></dt> <dd><p>1900 ...</p></dd> <dt><b class="const">zone</b></dt> <dd><p>-720 .. 720 (minutes east of GMT)</p></dd> </dl></dd> <dt><a name="4"><b class="cmd">::mime::finalize</b> <i class="arg">token</i> <span class="opt">?<b class="option">-subordinates</b> <b class="const">all</b> | <b class="const">dynamic</b> | <b class="const">none</b>?</span></a></dt> <dd><p>Destroys the message corresponding to <i class="arg">token</i> and returns the empty string.</p> <p><b class="option">-subordinates</b> specifies which messages comprising the body should also be destroyed. The default value is <b class="const">dynamic</b>, which destroys all component messages that were created by <b class="cmd">::mime::initialize</b>.</p></dd> <dt><a name="5"><b class="cmd">::mime::header</b> <b class="cmd">serialize</b> <i class="arg">value</i> <i class="arg">parameters</i></a></dt> <dd><p>Serialize a header.</p></dd> <dt><a name="6"><b class="cmd">::mime::header</b> <b class="cmd">get</b> <i class="arg">token</i> <span class="opt">?<i class="arg">key</i> | <b class="option">-names</b>?</span></a></dt> <dd><p>Returns the header of a message as a multidict where each value is a list containing the header value and any parameters for that value.</p> <p>If <i class="arg">name</i> is provided returns a list of values for that name, without regard to case.</p> <p>If <b class="option">-names</b> is provided, returns a list of all header names.</p></dd> <dt><a name="7"><b class="cmd">::mime::header</b> <b class="cmd"><a href="../../../../index.html#set">set</a></b> <i class="arg">token</i> <i class="arg">name value</i> <span class="opt">?<i class="arg">parameters</i> <span class="opt">?<b class="option">-mode</b> <b class="const">write</b> | <b class="const">append</b> | <b class="const">delete</b>?</span>?</span></a></dt> <dd><p>If <b class="const">append</b> is provided, creates a new header named <i class="arg">name</i> with the value of <i class="arg">value</i> is added. If <b class="const">write</b> is provided, deletes any existing headers whose names match <i class="arg">key</i> and then creates a new header named <i class="arg">key</i> with the value of <i class="arg">value</i>. If <b class="const">delete</b> is provided, deletes any existing header having a name that matches <i class="arg">key</i>. <i class="arg">parameters</i> is a dictionary of parameters for the header. Returns a list of strings containing the previous value associated with the key.</p> <p>The value for <b class="option">-mode</b> is one of:</p> <dl class="doctools_definitions"> <dt><b class="const">write</b></dt> <dd><p>The <i class="arg">key</i>/<i class="arg">value</i> is either created or overwritten (the default).</p></dd> <dt><b class="const">append</b></dt> <dd><p>Appends a new <i class="arg">key</i>/<i class="arg">value</i>.</p></dd> <dt><b class="const">delete</b></dt> <dd><p>Removes all values associated with the key. <i class="arg">value</i> is ignored.</p></dd> </dl></dd> <dt><a name="8"><b class="cmd">::mime::property</b> <i class="arg">token</i> <span class="opt">?<i class="arg">name</i> | <b class="option">-names</b>?</span></a></dt> <dd><p>Returns a dictionary of message properties. If <i class="arg">name</i> is provided, only the corresponding value is returned. If <b class="option">-names</b> is provided, a list of all property names is returned.</p> <p>properties:</p> <dl class="doctools_definitions"> <dt><b class="const">content</b></dt> <dd><p>The type/subtype of the content</p></dd> <dt><b class="const">encoding</b></dt> <dd><p>The "Content-Transfer-Encoding"</p></dd> <dt><b class="const">params</b></dt> <dd><p>A list of "Content-Type" parameters</p></dd> <dt><b class="const">parts</b></dt> <dd><p>A list of tokens for messages that should comprise a multipart body. Only exists if there are any such messages.</p></dd> <dt><b class="const">size</b></dt> <dd><p>The approximate size of the unencoded content.</p></dd> </dl></dd> <dt><a name="9"><b class="cmd">::mime::serialize</b> <i class="arg">token</i> <span class="opt">?<b class="option">-chan</b> <i class="arg">channel</i>?</span></a></dt> <dd><p>Return the serialization of the message corresponding to <i class="arg">token</i>. If <b class="option">-chan</b> is provided, write the message to <i class="arg">channel</i> and return the empty string. Pauses the current coroutine as needed to wait for input to become available.</p></dd> <dt><a name="10"><b class="cmd">::mime::parseaddress</b> <i class="arg">addresses</i></a></dt> <dd><p>Returns a list of describing the comma-separated 822-style <i class="arg">addresses</i>.</p> <p>Each dictionary contains the following keys, whose values may be the empty string:</p> <dl class="doctools_definitions"> <dt><b class="const">address</b></dt> <dd><p>local@domain</p></dd> <dt><b class="const">comment</b></dt> <dd><p>822-style comment</p></dd> <dt><b class="const">domain</b></dt> <dd><p>the domain part (rhs)</p></dd> <dt><b class="const">error</b></dt> <dd><p>non-empty on a parse error</p></dd> <dt><b class="const">group</b></dt> <dd><p>this address begins a group</p></dd> <dt><b class="const">friendly</b></dt> <dd><p>user-friendly rendering</p></dd> <dt><b class="const">local</b></dt> <dd><p>the local part (lhs)</p></dd> <dt><b class="const">memberP</b></dt> <dd><p>this address belongs to a group</p></dd> <dt><b class="const">phrase</b></dt> <dd><p>the phrase part</p></dd> <dt><b class="const">proper</b></dt> <dd><p>822-style address specification</p></dd> <dt><b class="const">route</b></dt> <dd><p>822-style route specification (obsolete)</p></dd> </dl></dd> <dt><a name="11"><b class="cmd">::mime::mapencoding</b> <i class="arg">encoding_name</i></a></dt> <dd><p>Maps Tcl encodings onto the proper names for their MIME charset type. This is only done for encodings whose charset types were known. The remaining encodings return "" for now.</p></dd> <dt><a name="12"><b class="cmd">::mime::reversemapencoding</b> <i class="arg">charset_type</i></a></dt> <dd><p>Maps MIME charset types onto tcl encoding names. Those that are unknown return "".</p></dd> </dl> </div> <div id="section2" class="doctools_section"><h2><a name="section2">KNOWN BUGS</a></h2> <dl class="doctools_definitions"> <dt>Tcllib Bug #447037</dt> <dd><p>This problem affects only people which are using Tcl and Mime on a |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/namespacex/namespacex.html.
︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 | <dd><p>Unsets all variables in the specified <i class="arg">namespace</i> and its child namespaces. The result of the command is the empty string.</p></dd> <dt><a name="13"><b class="cmd">::namespacex strip</b> <i class="arg">prefix</i> <i class="arg">namespaces</i></a></dt> <dd><p>Each item in <i class="arg">namespaces</i> must be the absolute normalized name of a child namespace of namespace <i class="arg">prefix</i>. Returns the corresponding list of relative names of child namespaces.</p></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">Bugs, Ideas, Feedback</a></h2> <p>This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category <em>namespacex</em> of the <a href="http://core.tcl.tk/tcllib/reportlist">Tcllib Trackers</a>. | > > > > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | <dd><p>Unsets all variables in the specified <i class="arg">namespace</i> and its child namespaces. The result of the command is the empty string.</p></dd> <dt><a name="13"><b class="cmd">::namespacex strip</b> <i class="arg">prefix</i> <i class="arg">namespaces</i></a></dt> <dd><p>Each item in <i class="arg">namespaces</i> must be the absolute normalized name of a child namespace of namespace <i class="arg">prefix</i>. Returns the corresponding list of relative names of child namespaces.</p></dd> <dt><a name="12"><b class="cmd">::namespacex strip</b> <i class="arg">namespace</i> <i class="arg">namespaces</i></a></dt> <dd><p>Each item in <i class="arg">namespaces</i> must be the absolute normalized name of a child namespace of <i class="arg">prefix</i>. Returns the corresponding list of relative names of child namespaces.</p></dd> </dl> </div> <div id="section3" class="doctools_section"><h2><a name="section3">Bugs, Ideas, Feedback</a></h2> <p>This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category <em>namespacex</em> of the <a href="http://core.tcl.tk/tcllib/reportlist">Tcllib Trackers</a>. |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/oometa/oometa.html.
︙ | ︙ | |||
189 190 191 192 193 194 195 | pieces where assembled into a single dict. The system mimics all of the standard dict commands, and addes the following:</p></dd> <dt><a name="2"><b class="cmd">oo::meta::info branchget</b> <span class="opt">?<i class="arg">key</i>?</span> <span class="opt">?...?</span></a></dt> <dd><p>Returns a dict representation of the element at <em>args</em>, but with any trailing : removed from field names.</p> <pre class="doctools_example"> ::oo::meta::info $myclass set option color {default: green widget: colorselect} puts [::oo::meta::info $myclass get option color] | | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | pieces where assembled into a single dict. The system mimics all of the standard dict commands, and addes the following:</p></dd> <dt><a name="2"><b class="cmd">oo::meta::info branchget</b> <span class="opt">?<i class="arg">key</i>?</span> <span class="opt">?...?</span></a></dt> <dd><p>Returns a dict representation of the element at <em>args</em>, but with any trailing : removed from field names.</p> <pre class="doctools_example"> ::oo::meta::info $myclass set option color {default: green widget: colorselect} puts [::oo::meta::info $myclass get option color] > {default green widget color} puts [::oo::meta::info $myclass branchget option color] > {default green widget color} </pre> </dd> <dt><a name="3"><b class="cmd">oo::meta::info branchset</b> <span class="opt">?<i class="arg">key...</i>?</span> <i class="arg">key</i> <i class="arg">value</i></a></dt> <dd><p>Merges <em>dict</em> with any other information contaned at node <span class="opt">?<i class="arg">key...</i>?</span>, and adding a trailing : to all field names.</p> |
︙ | ︙ |
Changes to idoc/www/tcllib/files/modules/practcl/practcl.html.
︙ | ︙ | |||
161 162 163 164 165 166 167 | <li class="doctools_section"><a href="#copyright">Copyright</a></li> </ul> </div> <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">TclOO 1.0</b></li> | < < | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | <li class="doctools_section"><a href="#copyright">Copyright</a></li> </ul> </div> <div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2> <div class="doctools_synopsis"> <ul class="doctools_requirements"> <li>package require <b class="pkgname">TclOO 1.0</b></li> <li><a href="#1">proc <b class="cmd">practcl::cat</b> <i class="arg">fname</i></a></li> <li><a href="#2">proc <b class="cmd">practcl::docstrip</b> <i class="arg">text</i></a></li> <li><a href="#3">proc <b class="cmd">putb</b> <span class="opt">?<i class="arg">map</i>?</span> <i class="arg">text</i></a></li> <li><a href="#4">proc <b class="cmd"><a href="../../../../index.html#proc">Proc</a></b> <i class="arg">name</i> <i class="arg">arglist</i> <i class="arg">body</i></a></li> <li><a href="#5">proc <b class="cmd">noop</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#6">proc <b class="cmd">practcl::debug</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> <li><a href="#7">proc <b class="cmd">practcl::doexec</b> <span class="opt">?<i class="arg">args</i>?</span></a></li> |
︙ | ︙ |
Changes to idoc/www/tcllib/toc.html.
︙ | ︙ | |||
96 97 98 99 100 101 102 | <td class="#doctools_tocleft" ><a name='cksum'><a href="files/modules/crc/cksum.html">cksum</a></td> <td class="#doctools_tocright">Calculate a cksum(1) compatible checksum</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> | | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | <td class="#doctools_tocleft" ><a name='cksum'><a href="files/modules/crc/cksum.html">cksum</a></td> <td class="#doctools_tocright">Calculate a cksum(1) compatible checksum</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clock_iso8601'><a href="files/modules/clock/iso8601.html">clock_iso8601</a></td> <td class="#doctools_tocright">Parsing ISO 8601 dates/times</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='clock_rfc2822'><a href="files/modules/clock/rfc2822.html">clock_rfc2822</a></td> <td class="#doctools_tocright">Parsing RFC 2822 dates/times</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='cmdline'><a href="files/modules/cmdline/cmdline.html">cmdline</a></td> <td class="#doctools_tocright">Procedures to process command lines and options.</td> </tr> |
︙ | ︙ | |||
492 493 494 495 496 497 498 | <td class="#doctools_tocleft" ><a name='fileutil_paths'><a href="files/modules/fileutil/paths.html">fileutil::paths</a></td> <td class="#doctools_tocright">Manage search path pools</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='fileutil_traverse'><a href="files/modules/fileutil/traverse.html">fileutil_traverse</a></td> <td class="#doctools_tocright">Iterative directory traversal</td> </tr> | | | | | | | | | | | | | | | | | | | | | | | | > > > > | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 | <td class="#doctools_tocleft" ><a name='fileutil_paths'><a href="files/modules/fileutil/paths.html">fileutil::paths</a></td> <td class="#doctools_tocright">Manage search path pools</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='fileutil_traverse'><a href="files/modules/fileutil/traverse.html">fileutil_traverse</a></td> <td class="#doctools_tocright">Iterative directory traversal</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ftp'><a href="files/modules/ftp/ftp.html">ftp</a></td> <td class="#doctools_tocright">Client-side tcl implementation of the ftp protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='ftp_geturl'><a href="files/modules/ftp/ftp_geturl.html">ftp::geturl</a></td> <td class="#doctools_tocright">Uri handler for ftp urls</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ftpd'><a href="files/modules/ftpd/ftpd.html">ftpd</a></td> <td class="#doctools_tocright">Tcl FTP server implementation</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='generator'><a href="files/modules/generator/generator.html">generator</a></td> <td class="#doctools_tocright">Procedures for creating and using generators.</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='gpx'><a href="files/modules/gpx/gpx.html">gpx</a></td> <td class="#doctools_tocright">Extracts waypoints, tracks and routes from GPX files</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_aycock'><a href="files/modules/grammar_aycock/aycock.html">grammar::aycock</a></td> <td class="#doctools_tocright">Aycock-Horspool-Earley parser generator for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_fa'><a href="files/modules/grammar_fa/fa.html">grammar::fa</a></td> <td class="#doctools_tocright">Create and manipulate finite automatons</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_fa_dacceptor'><a href="files/modules/grammar_fa/dacceptor.html">grammar::fa::dacceptor</a></td> <td class="#doctools_tocright">Create and use deterministic acceptors</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_fa_dexec'><a href="files/modules/grammar_fa/dexec.html">grammar::fa::dexec</a></td> <td class="#doctools_tocright">Execute deterministic finite automatons</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_fa_op'><a href="files/modules/grammar_fa/faop.html">grammar::fa::op</a></td> <td class="#doctools_tocright">Operations on finite automatons</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_me_cpu'><a href="files/modules/grammar_me/me_cpu.html">grammar::me::cpu</a></td> <td class="#doctools_tocright">Virtual machine implementation II for parsing token streams</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_me_cpu_core'><a href="files/modules/grammar_me/me_cpucore.html">grammar::me::cpu::core</a></td> <td class="#doctools_tocright">ME virtual machine state manipulation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_me_cpu_gasm'><a href="files/modules/grammar_me/gasm.html">grammar::me::cpu::gasm</a></td> <td class="#doctools_tocright">ME assembler</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_me_tcl'><a href="files/modules/grammar_me/me_tcl.html">grammar::me::tcl</a></td> <td class="#doctools_tocright">Virtual machine implementation I for parsing token streams</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_me_util'><a href="files/modules/grammar_me/me_util.html">grammar::me::util</a></td> <td class="#doctools_tocright">AST utilities</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_me_ast'><a href="files/modules/grammar_me/me_ast.html">grammar::me_ast</a></td> <td class="#doctools_tocright">Various representations of ASTs</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_me_intro'><a href="files/modules/grammar_me/me_intro.html">grammar::me_intro</a></td> <td class="#doctools_tocright">Introduction to virtual machines for parsing token streams</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_me_vm'><a href="files/modules/grammar_me/me_vm.html">grammar::me_vm</a></td> <td class="#doctools_tocright">Virtual machine for parsing token streams</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='grammar_peg'><a href="files/modules/grammar_peg/peg.html">grammar::peg</a></td> <td class="#doctools_tocright">Create and manipulate parsing expression grammars</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='grammar_peg_interp'><a href="files/modules/grammar_peg/peg_interp.html">grammar::peg::interp</a></td> <td class="#doctools_tocright">Interpreter for parsing expression grammars</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='hook'><a href="files/modules/hook/hook.html">hook</a></td> <td class="#doctools_tocright">Hooks</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='html'><a href="files/modules/html/html.html">html</a></td> <td class="#doctools_tocright">Procedures to generate HTML structures</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='htmlparse'><a href="files/modules/htmlparse/htmlparse.html">htmlparse</a></td> <td class="#doctools_tocright">Procedures to parse HTML strings</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='httpd'><a href="files/modules/httpd/httpd.html">httpd</a></td> <td class="#doctools_tocright">A TclOO and coroutine based web server</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='httpd'><a href="files/modules/httpd/httpd.html">httpd</a></td> <td class="#doctools_tocright">A TclOO and coroutine based web server</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='huddle'><a href="files/modules/yaml/huddle.html">huddle</a></td> <td class="#doctools_tocright">Create and manipulate huddle object</td> |
︙ | ︙ | |||
805 806 807 808 809 810 811 812 813 814 | <td class="#doctools_tocright">Basic statistical functions and procedures</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='math_trig'><a href="files/modules/math/trig.html">math::trig</a></td> <td class="#doctools_tocright">Trigonometric anf hyperbolic functions</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='md4'><a href="files/modules/md4/md4.html">md4</a></td> <td class="#doctools_tocright">MD4 Message-Digest Algorithm</td> </tr> | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 | <td class="#doctools_tocright">Basic statistical functions and procedures</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='math_trig'><a href="files/modules/math/trig.html">math::trig</a></td> <td class="#doctools_tocright">Trigonometric anf hyperbolic functions</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='math_trig'><a href="files/modules/math/trig.html">math::trig</a></td> <td class="#doctools_tocright">Trigonometric anf hyperbolic functions</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='md4'><a href="files/modules/md4/md4.html">md4</a></td> <td class="#doctools_tocright">MD4 Message-Digest Algorithm</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='md5'><a href="files/modules/md5/md5.html">md5</a></td> <td class="#doctools_tocright">MD5 Message-Digest Algorithm</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='md5crypt'><a href="files/modules/md5crypt/md5crypt.html">md5crypt</a></td> <td class="#doctools_tocright">MD5-based password encryption</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="files/modules/mime/mime.html">mime</a></td> <td class="#doctools_tocright">Manipulation of Internet messages</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='mpexpand'><a href="files/modules/doctools/mpexpand.html">mpexpand</a></td> <td class="#doctools_tocright">Markup processor</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='multiplexer'><a href="files/modules/multiplexer/multiplexer.html">multiplexer</a></td> <td class="#doctools_tocright">One-to-many communication with sockets.</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv'><a href="files/modules/nns/nns_client.html">nameserv</a></td> <td class="#doctools_tocright">Name service facility, Client</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv_auto'><a href="files/modules/nns/nns_auto.html">nameserv::auto</a></td> <td class="#doctools_tocright">Name service facility, Client Extension</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv_common'><a href="files/modules/nns/nns_common.html">nameserv::common</a></td> <td class="#doctools_tocright">Name service facility, shared definitions</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv_protocol'><a href="files/modules/nns/nns_protocol.html">nameserv::protocol</a></td> <td class="#doctools_tocright">Name service facility, client/server protocol</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv_server'><a href="files/modules/nns/nns_server.html">nameserv::server</a></td> <td class="#doctools_tocright">Name service facility, Server</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='namespacex'><a href="files/modules/namespacex/namespacex.html">namespacex</a></td> <td class="#doctools_tocright">Namespace utility commands</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ncgi'><a href="files/modules/ncgi/ncgi.html">ncgi</a></td> <td class="#doctools_tocright">Procedures to manipulate CGI values.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nettool'><a href="files/modules/nettool/nettool.html">nettool</a></td> <td class="#doctools_tocright">Tools for networked applications</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nmea'><a href="files/modules/nmea/nmea.html">nmea</a></td> <td class="#doctools_tocright">Process NMEA data</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nns'><a href="files/apps/nns.html">nns</a></td> <td class="#doctools_tocright">Name service facility, Commandline Client Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nns_intro'><a href="files/modules/nns/nns_intro.html">nns_intro</a></td> <td class="#doctools_tocright">Name service facility, introduction</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nnsd'><a href="files/apps/nnsd.html">nnsd</a></td> <td class="#doctools_tocright">Name service facility, Commandline Server Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nnslog'><a href="files/apps/nnslog.html">nnslog</a></td> <td class="#doctools_tocright">Name service facility, Commandline Logging Client Application</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nntp'><a href="files/modules/nntp/nntp.html">nntp</a></td> <td class="#doctools_tocright">Tcl client for the NNTP protocol</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ntp_time'><a href="files/modules/ntp/ntp_time.html">ntp_time</a></td> <td class="#doctools_tocright">Tcl Time Service Client</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='oauth'><a href="files/modules/oauth/oauth.html">oauth</a></td> <td class="#doctools_tocright">oauth API base signature</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='oo_util'><a href="files/modules/tool/meta.html">oo::util</a></td> <td class="#doctools_tocright">Utility commands for TclOO</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='oo_util'><a href="files/modules/ooutil/ooutil.html">oo::util</a></td> <td class="#doctools_tocright">Utility commands for TclOO</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='oometa'><a href="files/modules/oometa/oometa.html">oometa</a></td> <td class="#doctools_tocright">oo::meta A data registry for classess</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='otp'><a href="files/modules/otp/otp.html">otp</a></td> <td class="#doctools_tocright">One-Time Passwords</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='page'><a href="files/apps/page.html">page</a></td> <td class="#doctools_tocright">Parser Generator</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='page_intro'><a href="files/modules/page/page_intro.html">page_intro</a></td> <td class="#doctools_tocright">page introduction</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='page_pluginmgr'><a href="files/modules/page/page_pluginmgr.html">page_pluginmgr</a></td> <td class="#doctools_tocright">page plugin manager</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='page_util_flow'><a href="files/modules/page/page_util_flow.html">page_util_flow</a></td> <td class="#doctools_tocright">page dataflow/treewalker utility</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='page_util_norm_lemon'><a href="files/modules/page/page_util_norm_lemon.html">page_util_norm_lemon</a></td> <td class="#doctools_tocright">page AST normalization, LEMON</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='page_util_norm_peg'><a href="files/modules/page/page_util_norm_peg.html">page_util_norm_peg</a></td> <td class="#doctools_tocright">page AST normalization, PEG</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='page_util_peg'><a href="files/modules/page/page_util_peg.html">page_util_peg</a></td> <td class="#doctools_tocright">page PEG transformation utilities</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='page_util_quote'><a href="files/modules/page/page_util_quote.html">page_util_quote</a></td> <td class="#doctools_tocright">page character quoting utilities</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='picoirc'><a href="files/modules/irc/picoirc.html">picoirc</a></td> <td class="#doctools_tocright">Small and simple embeddable IRC client.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pki'><a href="files/modules/pki/pki.html">pki</a></td> <td class="#doctools_tocright">Implementation of the public key cipher</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pluginmgr'><a href="files/modules/pluginmgr/pluginmgr.html">pluginmgr</a></td> <td class="#doctools_tocright">Manage a plugin</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='png'><a href="files/modules/png/png.html">png</a></td> <td class="#doctools_tocright">PNG querying and manipulation of meta data</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pop3'><a href="files/modules/pop3/pop3.html">pop3</a></td> <td class="#doctools_tocright">Tcl client for POP3 email protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pop3d'><a href="files/modules/pop3d/pop3d.html">pop3d</a></td> <td class="#doctools_tocright">Tcl POP3 server implementation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pop3d_dbox'><a href="files/modules/pop3d/pop3d_dbox.html">pop3d::dbox</a></td> <td class="#doctools_tocright">Simple mailbox database for pop3d</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pop3d_udb'><a href="files/modules/pop3d/pop3d_udb.html">pop3d::udb</a></td> <td class="#doctools_tocright">Simple user database for pop3d</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='practcl'><a href="files/modules/practcl/practcl.html">practcl</a></td> <td class="#doctools_tocright">The Practcl Module</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='processman'><a href="files/modules/processman/processman.html">processman</a></td> <td class="#doctools_tocright">Tool for automating the period callback of commands</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='profiler'><a href="files/modules/profiler/profiler.html">profiler</a></td> <td class="#doctools_tocright">Tcl source code profiler</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt'><a href="files/apps/pt.html">pt</a></td> <td class="#doctools_tocright">Parser Tools Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_ast'><a href="files/modules/pt/pt_astree.html">pt::ast</a></td> <td class="#doctools_tocright">Abstract Syntax Tree Serialization</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_cparam_configuration_critcl'><a href="files/modules/pt/pt_cparam_config_critcl.html">pt::cparam::configuration::critcl</a></td> <td class="#doctools_tocright">C/PARAM, Canned configuration, Critcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_cparam_configuration_tea'><a href="files/modules/pt/pt_cparam_config_tea.html">pt::cparam::configuration::tea</a></td> <td class="#doctools_tocright">C/PARAM, Canned configuration, TEA</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_json_language'><a href="files/modules/pt/pt_json_language.html">pt::json_language</a></td> <td class="#doctools_tocright">The JSON Grammar Exchange Format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_param'><a href="files/modules/pt/pt_param.html">pt::param</a></td> <td class="#doctools_tocright">PackRat Machine Specification</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_pe'><a href="files/modules/pt/pt_pexpression.html">pt::pe</a></td> <td class="#doctools_tocright">Parsing Expression Serialization</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_pe_op'><a href="files/modules/pt/pt_pexpr_op.html">pt::pe::op</a></td> <td class="#doctools_tocright">Parsing Expression Utilities</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg'><a href="files/modules/pt/pt_pegrammar.html">pt::peg</a></td> <td class="#doctools_tocright">Parsing Expression Grammar Serialization</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_container'><a href="files/modules/pt/pt_peg_container.html">pt::peg::container</a></td> <td class="#doctools_tocright">PEG Storage</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_container_peg'><a href="files/modules/pt/pt_peg_container_peg.html">pt::peg::container::peg</a></td> <td class="#doctools_tocright">PEG Storage. Canned PEG grammar specification</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_export'><a href="files/modules/pt/pt_peg_export.html">pt::peg::export</a></td> <td class="#doctools_tocright">PEG Export</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_export_container'><a href="files/modules/pt/pt_peg_export_container.html">pt::peg::export::container</a></td> <td class="#doctools_tocright">PEG Export Plugin. Write CONTAINER format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_export_json'><a href="files/modules/pt/pt_peg_export_json.html">pt::peg::export::json</a></td> <td class="#doctools_tocright">PEG Export Plugin. Write JSON format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_export_peg'><a href="files/modules/pt/pt_peg_export_peg.html">pt::peg::export::peg</a></td> <td class="#doctools_tocright">PEG Export Plugin. Write PEG format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_from_container'><a href="files/modules/pt/pt_peg_from_container.html">pt::peg::from::container</a></td> <td class="#doctools_tocright">PEG Conversion. From CONTAINER format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_from_json'><a href="files/modules/pt/pt_peg_from_json.html">pt::peg::from::json</a></td> <td class="#doctools_tocright">PEG Conversion. Read JSON format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_from_peg'><a href="files/modules/pt/pt_peg_from_peg.html">pt::peg::from::peg</a></td> <td class="#doctools_tocright">PEG Conversion. Read PEG format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_import'><a href="files/modules/pt/pt_peg_import.html">pt::peg::import</a></td> <td class="#doctools_tocright">PEG Import</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_import_container'><a href="files/modules/pt/pt_peg_import_container.html">pt::peg::import::container</a></td> <td class="#doctools_tocright">PEG Import Plugin. From CONTAINER format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_import_json'><a href="files/modules/pt/pt_peg_import_json.html">pt::peg::import::json</a></td> <td class="#doctools_tocright">PEG Import Plugin. Read JSON format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_import_peg'><a href="files/modules/pt/pt_peg_import_peg.html">pt::peg::import::peg</a></td> <td class="#doctools_tocright">PEG Import Plugin. Read PEG format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_interp'><a href="files/modules/pt/pt_peg_interp.html">pt::peg::interp</a></td> <td class="#doctools_tocright">Interpreter for parsing expression grammars</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_to_container'><a href="files/modules/pt/pt_peg_to_container.html">pt::peg::to::container</a></td> <td class="#doctools_tocright">PEG Conversion. Write CONTAINER format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_to_cparam'><a href="files/modules/pt/pt_peg_to_cparam.html">pt::peg::to::cparam</a></td> <td class="#doctools_tocright">PEG Conversion. Write CPARAM format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_to_json'><a href="files/modules/pt/pt_peg_to_json.html">pt::peg::to::json</a></td> <td class="#doctools_tocright">PEG Conversion. Write JSON format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_to_param'><a href="files/modules/pt/pt_peg_to_param.html">pt::peg::to::param</a></td> <td class="#doctools_tocright">PEG Conversion. Write PARAM format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_to_peg'><a href="files/modules/pt/pt_peg_to_peg.html">pt::peg::to::peg</a></td> <td class="#doctools_tocright">PEG Conversion. Write PEG format</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_to_tclparam'><a href="files/modules/pt/pt_peg_to_tclparam.html">pt::peg::to::tclparam</a></td> <td class="#doctools_tocright">PEG Conversion. Write TCLPARAM format</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_peg_language'><a href="files/modules/pt/pt_peg_language.html">pt::peg_language</a></td> <td class="#doctools_tocright">PEG Language Tutorial</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_pegrammar'><a href="files/modules/pt/pt_peg_introduction.html">pt::pegrammar</a></td> <td class="#doctools_tocright">Introduction to Parsing Expression Grammars</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_pgen'><a href="files/modules/pt/pt_pgen.html">pt::pgen</a></td> <td class="#doctools_tocright">Parser Generator</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_rde'><a href="files/modules/pt/pt_rdengine.html">pt::rde</a></td> <td class="#doctools_tocright">Parsing Runtime Support, PARAM based</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_tclparam_configuration_nx'><a href="files/modules/pt/pt_tclparam_config_nx.html">pt::tclparam::configuration::nx</a></td> <td class="#doctools_tocright">Tcl/PARAM, Canned configuration, NX</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_tclparam_configuration_snit'><a href="files/modules/pt/pt_tclparam_config_snit.html">pt::tclparam::configuration::snit</a></td> <td class="#doctools_tocright">Tcl/PARAM, Canned configuration, Snit</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_tclparam_configuration_tcloo'><a href="files/modules/pt/pt_tclparam_config_tcloo.html">pt::tclparam::configuration::tcloo</a></td> <td class="#doctools_tocright">Tcl/PARAM, Canned configuration, Tcloo</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_util'><a href="files/modules/pt/pt_util.html">pt::util</a></td> <td class="#doctools_tocright">General utilities</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_export_api'><a href="files/modules/pt/pt_to_api.html">pt_export_api</a></td> <td class="#doctools_tocright">Parser Tools Export API</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_import_api'><a href="files/modules/pt/pt_from_api.html">pt_import_api</a></td> <td class="#doctools_tocright">Parser Tools Import API</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_introduction'><a href="files/modules/pt/pt_introduction.html">pt_introduction</a></td> <td class="#doctools_tocright">Introduction to Parser Tools</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_parse_peg'><a href="files/modules/pt/pt_parse_peg.html">pt_parse_peg</a></td> <td class="#doctools_tocright">Parser Tools PEG Parser</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pt_parser_api'><a href="files/modules/pt/pt_parser_api.html">pt_parser_api</a></td> <td class="#doctools_tocright">Parser API</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pt_peg_op'><a href="files/modules/pt/pt_peg_op.html">pt_peg_op</a></td> <td class="#doctools_tocright">Parser Tools PE Grammar Utility Operations</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='rc4'><a href="files/modules/rc4/rc4.html">rc4</a></td> <td class="#doctools_tocright">Implementation of the RC4 stream cipher</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='rcs'><a href="files/modules/rcs/rcs.html">rcs</a></td> <td class="#doctools_tocright">RCS low level utilities</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='report'><a href="files/modules/report/report.html">report</a></td> <td class="#doctools_tocright">Create and manipulate report objects</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='rest'><a href="files/modules/rest/rest.html">rest</a></td> <td class="#doctools_tocright">define REST web APIs and call them inline or asychronously</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ripemd128'><a href="files/modules/ripemd/ripemd128.html">ripemd128</a></td> <td class="#doctools_tocright">RIPEMD-128 Message-Digest Algorithm</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='ripemd160'><a href="files/modules/ripemd/ripemd160.html">ripemd160</a></td> <td class="#doctools_tocright">RIPEMD-160 Message-Digest Algorithm</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='s3'><a href="files/modules/amazon-s3/S3.html">S3</a></td> <td class="#doctools_tocright">Amazon S3 Web Service Interface</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sasl'><a href="files/modules/sasl/sasl.html">SASL</a></td> <td class="#doctools_tocright">Implementation of SASL mechanisms for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sasl_ntlm'><a href="files/modules/sasl/ntlm.html">SASL::NTLM</a></td> <td class="#doctools_tocright">Implementation of SASL NTLM mechanism for Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sasl_scram'><a href="files/modules/sasl/scram.html">SASL::SCRAM</a></td> <td class="#doctools_tocright">Implementation of SASL SCRAM mechanism for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sasl_xgoogletoken'><a href="files/modules/sasl/gtoken.html">SASL::XGoogleToken</a></td> <td class="#doctools_tocright">Implementation of SASL NTLM mechanism for Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sha1'><a href="files/modules/sha1/sha1.html">sha1</a></td> <td class="#doctools_tocright">SHA1 Message-Digest Algorithm</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sha256'><a href="files/modules/sha1/sha256.html">sha256</a></td> <td class="#doctools_tocright">SHA256 Message-Digest Algorithm</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='simulation_annealing'><a href="files/modules/simulation/annealing.html">simulation::annealing</a></td> <td class="#doctools_tocright">Simulated annealing</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='simulation_montecarlo'><a href="files/modules/simulation/montecarlo.html">simulation::montecarlo</a></td> <td class="#doctools_tocright">Monte Carlo simulations</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='simulation_random'><a href="files/modules/simulation/simulation_random.html">simulation::random</a></td> <td class="#doctools_tocright">Pseudo-random number generators</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='smtp'><a href="files/modules/mime/smtp.html">smtp</a></td> <td class="#doctools_tocright">Client-side tcl implementation of the smtp protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='smtpd'><a href="files/modules/smtpd/smtpd.html">smtpd</a></td> <td class="#doctools_tocright">Tcl SMTP server implementation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='snit'><a href="files/modules/snit/snit.html">snit</a></td> <td class="#doctools_tocright">Snit's Not Incr Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='snitfaq'><a href="files/modules/snit/snitfaq.html">snitfaq</a></td> <td class="#doctools_tocright">Snit Frequently Asked Questions</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='soundex'><a href="files/modules/soundex/soundex.html">soundex</a></td> <td class="#doctools_tocright">Soundex</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='stooop'><a href="files/modules/stooop/stooop.html">stooop</a></td> <td class="#doctools_tocright">Object oriented extension.</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='string_token'><a href="files/modules/string/token.html">string::token</a></td> <td class="#doctools_tocright">Regex based iterative lexing</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='string_token_shell'><a href="files/modules/string/token_shell.html">string::token::shell</a></td> <td class="#doctools_tocright">Parsing of shell command line</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='stringprep'><a href="files/modules/stringprep/stringprep.html">stringprep</a></td> <td class="#doctools_tocright">Implementation of stringprep</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='stringprep_data'><a href="files/modules/stringprep/stringprep_data.html">stringprep::data</a></td> <td class="#doctools_tocright">stringprep data tables, generated, internal</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='struct_disjointset'><a href="files/modules/struct/disjointset.html">struct::disjointset</a></td> <td class="#doctools_tocright">Disjoint set data structure</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='struct_graph'><a href="files/modules/struct/graph.html">struct::graph</a></td> <td class="#doctools_tocright">Create and manipulate directed graph objects</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='struct_graph_op'><a href="files/modules/struct/graphops.html">struct::graph::op</a></td> <td class="#doctools_tocright">Operation for (un)directed graph objects</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='struct_graph_v1'><a href="files/modules/struct/graph1.html">struct::graph_v1</a></td> <td class="#doctools_tocright">Create and manipulate directed graph objects</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='struct_list'><a href="files/modules/struct/struct_list.html">struct::list</a></td> <td class="#doctools_tocright">Procedures for manipulating lists</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='struct_map'><a href="files/modules/struct/struct_map.html">struct::map</a></td> <td class="#doctools_tocright">Manage key/value maps</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='struct_matrix'><a href="files/modules/struct/matrix.html">struct::matrix</a></td> <td class="#doctools_tocright">Create and manipulate matrix objects</td> </tr> |
︙ | ︙ | |||
1468 1469 1470 1471 1472 1473 1474 | <td class="#doctools_tocleft" ><a name='tcl_community_communication'><a href="files/devdoc/tcl_community_communication.html">tcl_community_communication</a></td> <td class="#doctools_tocright">Tcl Community - Kind Communication</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcldes'><a href="files/modules/des/tcldes.html">tclDES</a></td> <td class="#doctools_tocright">Implementation of the DES and triple-DES ciphers</td> </tr> | | | | | | | | | | | | | | | | | | | | | | | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 | <td class="#doctools_tocleft" ><a name='tcl_community_communication'><a href="files/devdoc/tcl_community_communication.html">tcl_community_communication</a></td> <td class="#doctools_tocright">Tcl Community - Kind Communication</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcldes'><a href="files/modules/des/tcldes.html">tclDES</a></td> <td class="#doctools_tocright">Implementation of the DES and triple-DES ciphers</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcldesjr'><a href="files/modules/des/tcldesjr.html">tclDESjr</a></td> <td class="#doctools_tocright">Implementation of the DES and triple-DES ciphers</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tcldocstrip'><a href="files/apps/tcldocstrip.html">tcldocstrip</a></td> <td class="#doctools_tocright">Tcl-based Docstrip Processor</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tcllib_devguide'><a href="files/devdoc/tcllib_devguide.html">tcllib_devguide</a></td> <td class="#doctools_tocright">Tcllib - The Developer's Guide</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcllib_install_guide'><a href="files/devdoc/tcllib_installer.html">tcllib_install_guide</a></td> <td class="#doctools_tocright">Tcllib - The Installer's Guide</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tcllib_ip'><a href="files/modules/dns/tcllib_ip.html">tcllib_ip</a></td> <td class="#doctools_tocright">IPv4 and IPv6 address manipulation</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tcllib_license'><a href="files/devdoc/tcllib_license.html">tcllib_license</a></td> <td class="#doctools_tocright">Tcllib - License</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tcllib_releasemgr'><a href="files/devdoc/tcllib_releasemgr.html">tcllib_releasemgr</a></td> <td class="#doctools_tocright">Tcllib - The Release Manager's Guide</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcllib_sources'><a href="files/devdoc/tcllib_sources.html">tcllib_sources</a></td> <td class="#doctools_tocright">Tcllib - How To Get The Sources</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tepam'><a href="files/modules/tepam/tepam_introduction.html">tepam</a></td> <td class="#doctools_tocright">An introduction into TEPAM, Tcl's Enhanced Procedure and Argument Manager</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tepam_argument_dialogbox'><a href="files/modules/tepam/tepam_argument_dialogbox.html">tepam::argument_dialogbox</a></td> <td class="#doctools_tocright">TEPAM argument_dialogbox, reference manual</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tepam_doc_gen'><a href="files/modules/tepam/tepam_doc_gen.html">tepam::doc_gen</a></td> <td class="#doctools_tocright">TEPAM DOC Generation, reference manual</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='tepam_procedure'><a href="files/modules/tepam/tepam_procedure.html">tepam::procedure</a></td> <td class="#doctools_tocright">TEPAM procedure, reference manual</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='term'><a href="files/modules/term/term.html">term</a></td> <td class="#doctools_tocright">General terminal control</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='term_ansi_code'><a href="files/modules/term/ansi_code.html">term::ansi::code</a></td> <td class="#doctools_tocright">Helper for control sequences</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='term_ansi_code_attr'><a href="files/modules/term/ansi_cattr.html">term::ansi::code::attr</a></td> <td class="#doctools_tocright">ANSI attribute sequences</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='term_ansi_code_ctrl'><a href="files/modules/term/ansi_cctrl.html">term::ansi::code::ctrl</a></td> <td class="#doctools_tocright">ANSI control sequences</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='term_ansi_code_macros'><a href="files/modules/term/ansi_cmacros.html">term::ansi::code::macros</a></td> <td class="#doctools_tocright">Macro sequences</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='term_ansi_ctrl_unix'><a href="files/modules/term/ansi_ctrlu.html">term::ansi::ctrl::unix</a></td> <td class="#doctools_tocright">Control operations and queries</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='term_ansi_send'><a href="files/modules/term/ansi_send.html">term::ansi::send</a></td> <td class="#doctools_tocright">Output of ANSI control sequences to terminals</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='term_interact_menu'><a href="files/modules/term/imenu.html">term::interact::menu</a></td> <td class="#doctools_tocright">Terminal widget, menu</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='term_interact_pager'><a href="files/modules/term/ipager.html">term::interact::pager</a></td> <td class="#doctools_tocright">Terminal widget, paging</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='term_receive'><a href="files/modules/term/receive.html">term::receive</a></td> <td class="#doctools_tocright">General input from terminals</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='term_receive_bind'><a href="files/modules/term/term_bind.html">term::receive::bind</a></td> <td class="#doctools_tocright">Keyboard dispatch from terminals</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='term_send'><a href="files/modules/term/term_send.html">term::send</a></td> <td class="#doctools_tocright">General output to terminals</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='textutil'><a href="files/modules/textutil/textutil.html">textutil</a></td> <td class="#doctools_tocright">Procedures to manipulate texts and strings.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='textutil_adjust'><a href="files/modules/textutil/adjust.html">textutil::adjust</a></td> <td class="#doctools_tocright">Procedures to adjust, indent, and undent paragraphs</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='textutil_expander'><a href="files/modules/textutil/expander.html">textutil::expander</a></td> <td class="#doctools_tocright">Procedures to process templates and expand text.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='textutil_patch'><a href="files/modules/textutil/patch.html">textutil::patch</a></td> <td class="#doctools_tocright">Application of uni-diff patches to directory trees</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='textutil_repeat'><a href="files/modules/textutil/repeat.html">textutil::repeat</a></td> <td class="#doctools_tocright">Procedures to repeat strings.</td> </tr> |
︙ | ︙ |
Changes to idoc/www/toc.html.
︙ | ︙ | |||
889 890 891 892 893 894 895 | <td class="#doctools_tocleft" ><a name='imap4'><a href="tcllib/files/modules/imap4/imap4.html">imap4</a></td> <td class="#doctools_tocright">imap client-side tcl implementation of imap protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='irc'><a href="tcllib/files/modules/irc/irc.html">irc</a></td> <td class="#doctools_tocright">Create IRC connection and interface.</td> </tr> | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 | <td class="#doctools_tocleft" ><a name='imap4'><a href="tcllib/files/modules/imap4/imap4.html">imap4</a></td> <td class="#doctools_tocright">imap client-side tcl implementation of imap protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='irc'><a href="tcllib/files/modules/irc/irc.html">irc</a></td> <td class="#doctools_tocright">Create IRC connection and interface.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='ldap'><a href="tcllib/files/modules/ldap/ldap.html">ldap</a></td> <td class="#doctools_tocright">LDAP client</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ldapx'><a href="tcllib/files/modules/ldap/ldapx.html">ldapx</a></td> <td class="#doctools_tocright">LDAP extended object interface</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv'><a href="tcllib/files/modules/nns/nns_client.html">nameserv</a></td> <td class="#doctools_tocright">Name service facility, Client</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv_auto'><a href="tcllib/files/modules/nns/nns_auto.html">nameserv::auto</a></td> <td class="#doctools_tocright">Name service facility, Client Extension</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv_common'><a href="tcllib/files/modules/nns/nns_common.html">nameserv::common</a></td> <td class="#doctools_tocright">Name service facility, shared definitions</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv_protocol'><a href="tcllib/files/modules/nns/nns_protocol.html">nameserv::protocol</a></td> <td class="#doctools_tocright">Name service facility, client/server protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv_server'><a href="tcllib/files/modules/nns/nns_server.html">nameserv::server</a></td> <td class="#doctools_tocright">Name service facility, Server</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nmea'><a href="tcllib/files/modules/nmea/nmea.html">nmea</a></td> <td class="#doctools_tocright">Process NMEA data</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nns'><a href="tcllib/files/apps/nns.html">nns</a></td> <td class="#doctools_tocright">Name service facility, Commandline Client Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nns_intro'><a href="tcllib/files/modules/nns/nns_intro.html">nns_intro</a></td> <td class="#doctools_tocright">Name service facility, introduction</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nnsd'><a href="tcllib/files/apps/nnsd.html">nnsd</a></td> <td class="#doctools_tocright">Name service facility, Commandline Server Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nnslog'><a href="tcllib/files/apps/nnslog.html">nnslog</a></td> <td class="#doctools_tocright">Name service facility, Commandline Logging Client Application</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nntp'><a href="tcllib/files/modules/nntp/nntp.html">nntp</a></td> <td class="#doctools_tocright">Tcl client for the NNTP protocol</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ntp_time'><a href="tcllib/files/modules/ntp/ntp_time.html">ntp_time</a></td> <td class="#doctools_tocright">Tcl Time Service Client</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='oauth'><a href="tcllib/files/modules/oauth/oauth.html">oauth</a></td> <td class="#doctools_tocright">oauth API base signature</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='picoirc'><a href="tcllib/files/modules/irc/picoirc.html">picoirc</a></td> <td class="#doctools_tocright">Small and simple embeddable IRC client.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pop3'><a href="tcllib/files/modules/pop3/pop3.html">pop3</a></td> <td class="#doctools_tocright">Tcl client for POP3 email protocol</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pop3d'><a href="tcllib/files/modules/pop3d/pop3d.html">pop3d</a></td> <td class="#doctools_tocright">Tcl POP3 server implementation</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pop3d_dbox'><a href="tcllib/files/modules/pop3d/pop3d_dbox.html">pop3d::dbox</a></td> <td class="#doctools_tocright">Simple mailbox database for pop3d</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pop3d_udb'><a href="tcllib/files/modules/pop3d/pop3d_udb.html">pop3d::udb</a></td> <td class="#doctools_tocright">Simple user database for pop3d</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='s3'><a href="tcllib/files/modules/amazon-s3/S3.html">S3</a></td> <td class="#doctools_tocright">Amazon S3 Web Service Interface</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sasl'><a href="tcllib/files/modules/sasl/sasl.html">SASL</a></td> <td class="#doctools_tocright">Implementation of SASL mechanisms for Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sasl_ntlm'><a href="tcllib/files/modules/sasl/ntlm.html">SASL::NTLM</a></td> <td class="#doctools_tocright">Implementation of SASL NTLM mechanism for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sasl_scram'><a href="tcllib/files/modules/sasl/scram.html">SASL::SCRAM</a></td> <td class="#doctools_tocright">Implementation of SASL SCRAM mechanism for Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sasl_xgoogletoken'><a href="tcllib/files/modules/sasl/gtoken.html">SASL::XGoogleToken</a></td> <td class="#doctools_tocright">Implementation of SASL NTLM mechanism for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='smtp'><a href="tcllib/files/modules/mime/smtp.html">smtp</a></td> <td class="#doctools_tocright">Client-side tcl implementation of the smtp protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='smtpd'><a href="tcllib/files/modules/smtpd/smtpd.html">smtpd</a></td> <td class="#doctools_tocright">Tcl SMTP server implementation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcllib_ip'><a href="tcllib/files/modules/dns/tcllib_ip.html">tcllib_ip</a></td> <td class="#doctools_tocright">IPv4 and IPv6 address manipulation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='udpcluster'><a href="tcllib/files/modules/udpcluster/udpcluster.html">udpcluster</a></td> <td class="#doctools_tocright">UDP Peer-to-Peer cluster</td> </tr> |
︙ | ︙ | |||
1570 1571 1572 1573 1574 1575 1576 | </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='markdown'><a href="tcllib/files/modules/markdown/markdown.html">markdown</a></td> <td class="#doctools_tocright">Converts Markdown text to HTML</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> | | | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 | </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='markdown'><a href="tcllib/files/modules/markdown/markdown.html">markdown</a></td> <td class="#doctools_tocright">Converts Markdown text to HTML</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> <td class="#doctools_tocright">Manipulation of Internet messages</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='rcs'><a href="tcllib/files/modules/rcs/rcs.html">rcs</a></td> <td class="#doctools_tocright">RCS low level utilities</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='string_token'><a href="tcllib/files/modules/string/token.html">string::token</a></td> |
︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 | </table></dl> <dl><dt><a name='cache'>cache</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='cache_async'><a href="tcllib/files/modules/cache/async.html">cache::async</a></td> <td class="#doctools_tocright">Asynchronous in-memory cache</td> </tr> </table></dl> <dl><dt><a name='clay'>clay</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="tcllib/files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> | > > > > > > > | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 | </table></dl> <dl><dt><a name='cache'>cache</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='cache_async'><a href="tcllib/files/modules/cache/async.html">cache::async</a></td> <td class="#doctools_tocright">Asynchronous in-memory cache</td> </tr> </table></dl> <dl><dt><a name='clay'>clay<dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="tcllib/files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> </table></dl> <dl><dt><a name='clay'>clay</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="tcllib/files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> |
︙ | ︙ | |||
2913 2914 2915 2916 2917 2918 2919 | <td class="#doctools_tocright">MD5-based password encryption</td> </tr> </table></dl> <dl><dt><a name='mime'>mime</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> | | | 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 | <td class="#doctools_tocright">MD5-based password encryption</td> </tr> </table></dl> <dl><dt><a name='mime'>mime</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> <td class="#doctools_tocright">Manipulation of Internet messages</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='smtp'><a href="tcllib/files/modules/mime/smtp.html">smtp</a></td> <td class="#doctools_tocright">Client-side tcl implementation of the smtp protocol</td> </tr> </table></dl> <dl><dt><a name='multiplexer'>multiplexer</dt><dd> |
︙ | ︙ |
Changes to idoc/www/toc0.html.
︙ | ︙ | |||
889 890 891 892 893 894 895 | <td class="#doctools_tocleft" ><a name='imap4'><a href="tcllib/files/modules/imap4/imap4.html">imap4</a></td> <td class="#doctools_tocright">imap client-side tcl implementation of imap protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='irc'><a href="tcllib/files/modules/irc/irc.html">irc</a></td> <td class="#doctools_tocright">Create IRC connection and interface.</td> </tr> | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 | <td class="#doctools_tocleft" ><a name='imap4'><a href="tcllib/files/modules/imap4/imap4.html">imap4</a></td> <td class="#doctools_tocright">imap client-side tcl implementation of imap protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='irc'><a href="tcllib/files/modules/irc/irc.html">irc</a></td> <td class="#doctools_tocright">Create IRC connection and interface.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='ldap'><a href="tcllib/files/modules/ldap/ldap.html">ldap</a></td> <td class="#doctools_tocright">LDAP client</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ldapx'><a href="tcllib/files/modules/ldap/ldapx.html">ldapx</a></td> <td class="#doctools_tocright">LDAP extended object interface</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv'><a href="tcllib/files/modules/nns/nns_client.html">nameserv</a></td> <td class="#doctools_tocright">Name service facility, Client</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv_auto'><a href="tcllib/files/modules/nns/nns_auto.html">nameserv::auto</a></td> <td class="#doctools_tocright">Name service facility, Client Extension</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv_common'><a href="tcllib/files/modules/nns/nns_common.html">nameserv::common</a></td> <td class="#doctools_tocright">Name service facility, shared definitions</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nameserv_protocol'><a href="tcllib/files/modules/nns/nns_protocol.html">nameserv::protocol</a></td> <td class="#doctools_tocright">Name service facility, client/server protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nameserv_server'><a href="tcllib/files/modules/nns/nns_server.html">nameserv::server</a></td> <td class="#doctools_tocright">Name service facility, Server</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nmea'><a href="tcllib/files/modules/nmea/nmea.html">nmea</a></td> <td class="#doctools_tocright">Process NMEA data</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nns'><a href="tcllib/files/apps/nns.html">nns</a></td> <td class="#doctools_tocright">Name service facility, Commandline Client Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nns_intro'><a href="tcllib/files/modules/nns/nns_intro.html">nns_intro</a></td> <td class="#doctools_tocright">Name service facility, introduction</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nnsd'><a href="tcllib/files/apps/nnsd.html">nnsd</a></td> <td class="#doctools_tocright">Name service facility, Commandline Server Application</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='nnslog'><a href="tcllib/files/apps/nnslog.html">nnslog</a></td> <td class="#doctools_tocright">Name service facility, Commandline Logging Client Application</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='nntp'><a href="tcllib/files/modules/nntp/nntp.html">nntp</a></td> <td class="#doctools_tocright">Tcl client for the NNTP protocol</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='ntp_time'><a href="tcllib/files/modules/ntp/ntp_time.html">ntp_time</a></td> <td class="#doctools_tocright">Tcl Time Service Client</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='oauth'><a href="tcllib/files/modules/oauth/oauth.html">oauth</a></td> <td class="#doctools_tocright">oauth API base signature</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='picoirc'><a href="tcllib/files/modules/irc/picoirc.html">picoirc</a></td> <td class="#doctools_tocright">Small and simple embeddable IRC client.</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pop3'><a href="tcllib/files/modules/pop3/pop3.html">pop3</a></td> <td class="#doctools_tocright">Tcl client for POP3 email protocol</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pop3d'><a href="tcllib/files/modules/pop3d/pop3d.html">pop3d</a></td> <td class="#doctools_tocright">Tcl POP3 server implementation</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='pop3d_dbox'><a href="tcllib/files/modules/pop3d/pop3d_dbox.html">pop3d::dbox</a></td> <td class="#doctools_tocright">Simple mailbox database for pop3d</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='pop3d_udb'><a href="tcllib/files/modules/pop3d/pop3d_udb.html">pop3d::udb</a></td> <td class="#doctools_tocright">Simple user database for pop3d</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='s3'><a href="tcllib/files/modules/amazon-s3/S3.html">S3</a></td> <td class="#doctools_tocright">Amazon S3 Web Service Interface</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sasl'><a href="tcllib/files/modules/sasl/sasl.html">SASL</a></td> <td class="#doctools_tocright">Implementation of SASL mechanisms for Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sasl_ntlm'><a href="tcllib/files/modules/sasl/ntlm.html">SASL::NTLM</a></td> <td class="#doctools_tocright">Implementation of SASL NTLM mechanism for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='sasl_scram'><a href="tcllib/files/modules/sasl/scram.html">SASL::SCRAM</a></td> <td class="#doctools_tocright">Implementation of SASL SCRAM mechanism for Tcl</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='sasl_xgoogletoken'><a href="tcllib/files/modules/sasl/gtoken.html">SASL::XGoogleToken</a></td> <td class="#doctools_tocright">Implementation of SASL NTLM mechanism for Tcl</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='smtp'><a href="tcllib/files/modules/mime/smtp.html">smtp</a></td> <td class="#doctools_tocright">Client-side tcl implementation of the smtp protocol</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='smtpd'><a href="tcllib/files/modules/smtpd/smtpd.html">smtpd</a></td> <td class="#doctools_tocright">Tcl SMTP server implementation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='tcllib_ip'><a href="tcllib/files/modules/dns/tcllib_ip.html">tcllib_ip</a></td> <td class="#doctools_tocright">IPv4 and IPv6 address manipulation</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='udpcluster'><a href="tcllib/files/modules/udpcluster/udpcluster.html">udpcluster</a></td> <td class="#doctools_tocright">UDP Peer-to-Peer cluster</td> </tr> |
︙ | ︙ | |||
1570 1571 1572 1573 1574 1575 1576 | </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='markdown'><a href="tcllib/files/modules/markdown/markdown.html">markdown</a></td> <td class="#doctools_tocright">Converts Markdown text to HTML</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> | | | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 | </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='markdown'><a href="tcllib/files/modules/markdown/markdown.html">markdown</a></td> <td class="#doctools_tocright">Converts Markdown text to HTML</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> <td class="#doctools_tocright">Manipulation of Internet messages</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='rcs'><a href="tcllib/files/modules/rcs/rcs.html">rcs</a></td> <td class="#doctools_tocright">RCS low level utilities</td> </tr> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='string_token'><a href="tcllib/files/modules/string/token.html">string::token</a></td> |
︙ | ︙ |
Changes to idoc/www/toc1.html.
︙ | ︙ | |||
129 130 131 132 133 134 135 136 137 138 139 140 141 142 | </table></dl> <dl><dt><a name='cache'>cache</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='cache_async'><a href="tcllib/files/modules/cache/async.html">cache::async</a></td> <td class="#doctools_tocright">Asynchronous in-memory cache</td> </tr> </table></dl> <dl><dt><a name='clay'>clay</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="tcllib/files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> | > > > > > > > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | </table></dl> <dl><dt><a name='cache'>cache</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='cache_async'><a href="tcllib/files/modules/cache/async.html">cache::async</a></td> <td class="#doctools_tocright">Asynchronous in-memory cache</td> </tr> </table></dl> <dl><dt><a name='clay'>clay<dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="tcllib/files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> </table></dl> <dl><dt><a name='clay'>clay</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='clay'><a href="tcllib/files/modules/clay/clay.html">clay</a></td> <td class="#doctools_tocright">A minimalist framework for large scale OO Projects</td> </tr> |
︙ | ︙ | |||
1047 1048 1049 1050 1051 1052 1053 | <td class="#doctools_tocright">MD5-based password encryption</td> </tr> </table></dl> <dl><dt><a name='mime'>mime</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> | | | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 | <td class="#doctools_tocright">MD5-based password encryption</td> </tr> </table></dl> <dl><dt><a name='mime'>mime</dt><dd> <table class="#doctools_toc"> <tr class="#doctools_toceven" > <td class="#doctools_tocleft" ><a name='mime'><a href="tcllib/files/modules/mime/mime.html">mime</a></td> <td class="#doctools_tocright">Manipulation of Internet messages</td> </tr> <tr class="#doctools_tocodd" > <td class="#doctools_tocleft" ><a name='smtp'><a href="tcllib/files/modules/mime/smtp.html">smtp</a></td> <td class="#doctools_tocright">Client-side tcl implementation of the smtp protocol</td> </tr> </table></dl> <dl><dt><a name='multiplexer'>multiplexer</dt><dd> |
︙ | ︙ |
Changes to modules/asn/asn.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal asn.tcl asn } # Converts binary encoded structure into hexadecimal dump |
︙ | ︙ |
Changes to modules/base32/base32.test.
1 2 3 4 5 6 7 8 9 10 11 | # -*- tcl -*- Tests for "base32" # This testsuite is in the public domain. #__________________________________________ # RCS: @(#) $Id: base32.test,v 1.4 2008/03/22 23:46:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # -*- tcl -*- Tests for "base32" # This testsuite is in the public domain. #__________________________________________ # RCS: @(#) $Id: base32.test,v 1.4 2008/03/22 23:46:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 testing { useLocal base32core.tcl base32::core useTcllibC useLocalKeep base32.tcl base32 TestAccelInit base32 |
︙ | ︙ |
Changes to modules/base32/base32hex.test.
1 2 3 4 5 6 7 8 9 10 11 | # -*- tcl -*- Tests for "base32" # This testsuite is in the public domain. #__________________________________________ # RCS: @(#) $Id: base32hex.test,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # -*- tcl -*- Tests for "base32" # This testsuite is in the public domain. #__________________________________________ # RCS: @(#) $Id: base32hex.test,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 testing { useLocal base32core.tcl base32::core useTcllibC useLocalKeep base32hex.tcl base32::hex TestAccelInit base32::hex |
︙ | ︙ |
Changes to modules/base64/ascii85.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | package require tcltest source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | package require tcltest source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal ascii85.tcl ascii85 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/base64/base64.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal base64.tcl base64 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/base64/uuencode.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useTcllibC useLocalKeep uuencode.tcl uuencode } |
︙ | ︙ |
Changes to modules/base64/yencode.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # RCS: @(#) $Id: yencode.test,v 1.11 2008/12/12 04:57:46 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join [file dirname [file dirname [ file join [pwd] [info script]]]] devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # RCS: @(#) $Id: yencode.test,v 1.11 2008/12/12 04:57:46 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join [file dirname [file dirname [ file join [pwd] [info script]]]] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { # FUTURE: Switch tcl/critcl implementations useTcllibC useLocalKeep yencode.tcl yencode } |
︙ | ︙ |
Changes to modules/bee/bee.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # bee.test: tests for the bee encoding. # # Copyright (c) 2004,2018 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # bee.test: tests for the bee encoding. # # Copyright (c) 2004,2018 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal bee.tcl bee } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/bibtex/bibtex.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # bibtex.test: tests for the bibtex parser. # # Copyright (c) 2005 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # bibtex.test: tests for the bibtex parser. # # Copyright (c) 2005 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal bibtex.tcl bibtex } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/blowfish/blowfish.test.
1 2 3 4 5 6 7 8 9 10 | # blowfish.test - Copyright (C) 2004 Pat Thoyts <[email protected]> # # $Id: blowfish.test,v 1.11 2007/09/17 14:19:07 patthoyts Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # blowfish.test - Copyright (C) 2004 Pat Thoyts <[email protected]> # # $Id: blowfish.test,v 1.11 2007/09/17 14:19:07 patthoyts Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal blowfish.tcl blowfish } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/cache/async.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testing { useLocal async.tcl cache::async } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/calendar/gregorian.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # #---------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # #---------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal calendar.tcl calendar } #---------------------------------------------------------------------- |
︙ | ︙ |
Added modules/chan/base.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # # ## ### ##### ######## ############# # copyright # # 2018 # # Poor Yorick # # ## ### ##### ######## ############# package require ego tcllib::ego .new ::tcllib::chan::base ::tcllib::chan::base .eval { proc .init {_ channame args} { $_ .vars chan close if {$channame ni [::chan names]} { error [list {unknown channel} $channame] } set chan $channame $_ .ondelete [list ::apply {{_ channame} { $_ .vars close if {$close} { ::close $channame } }} $_ $channame] set close 1 if {[llength $args]} { $_ configure {*}$args } return $_ } .my .method .init proc configure {_ args} { $_ .vars chan if {[llength $args] == 1} { lassign $args key switch $key { -chan { return $chan } } set res [::chan configure $chan {*}$args] } elseif {[llength $args]} { dict size $args foreach {key val} $args[set args {}] { switch $key { -chan { set chan $val } -close { $_ $ close [expr {!!$val}] } default { lappend args $key $val } } } if {[llength $args]} { ::chan configure $chan {*}$args } set res {} } else { set res [list {*}[::chan configure $chan {*}$args] -chan $chan] } return $res } .my .method configure proc copy {_ target} { ::chan copy [$_ $ chan] $target } .my .method copy proc gets {_ args} { uplevel 1 [list ::gets [$_ $ chan] {*}$args] } .my .method gets proc pending {_ args} { uplevel 1 [list ::pending {*}$args [$_ $ chan]] } .my .method pending proc puts {_ args} { uplevel 1 [list ::puts {*}[lrange $args 0 end-1] [$_ $ chan] {*}[ lrange $args end end]] } .my .method puts proc read {_ args} { uplevel 1 [list ::read {*}[lrange $args 0 end-1] [$_ $ chan] {*}[ lrange $args end end]] } .my .method read apply [list {} { foreach name { blocked close eof event flush names pop posteven push seek tell truncate } { proc $name {_ args} [string map [ list @name@ [list $name]] { ::chan @name@ [$_ $ chan] {*}$args }] .my .method $name } } [namespace current]] } namespace eval ::tcllib::chan { namespace export base } package provide {chan base} 0.1 |
Added modules/chan/base.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/env tclsh source [file join \ [file dirname [file dirname [file dirname [ file normalize [info script]/...]]]]/devtools/testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2.0 package require tcl::chan::string package require {chan base} namespace import ::tcllib::chan::base proc main {} { variable done set data1 abcdefghijklmnopqrstuvwxyz test chan-object-closeondelete { } -body { base .new chan1 [::tcl::chan::string $data1] set name [chan1 $ chan] lappend res [expr {$name in [chan names]}] chan1 close lappend res [expr {$name in [chan names]}] } -result {1 0} testsuiteCleanup set done 1 } after 0 coroutine [info cmdcount]_main main vwait [namespace current]::done |
Added modules/chan/coroutine.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/tclsh # # ## ### ##### ######## ############# # copyright # # 2018 # # Poor Yorick # # ## ### ##### ######## ############# package require coroutine package require ego namespace eval ::tcllib::chan::coroutine { proc [namespace current] chan { if {![string match ::* $chan]} { set chan [uplevel 1 [list ::namespace which $chan]] } $chan .specialize foreach name { gets read } { $chan .method $name coroutine::$name } return $chan } proc gets {_ args} { $_ .vars chan tailcall ::coroutine::util::gets $chan {*}$args } proc read {_ args} { $_ .vars chan tailcall ::coroutine::util::read $chan {*}$args } } package provide {chan coroutine} 0.1 namespace eval ::tcllib::chan { namespace export coroutine } |
Added modules/chan/coroutine.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/tclsh source [file join \ [file dirname [file dirname [file dirname [ file normalize [info script]/...]]]]/devtools/testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2.0 package require {chan base} package require {chan coroutine} package require tcl::chan::string proc main {} {try { variable done test getslimit-configure {} -body { ::tcllib::chan::base .new chan1 ::tcllib::chan::coroutine chan1 chan1 .init [::tcl::chan::string \ {Curiosity governs the first moment}] chan1 read } -cleanup { rename chan1 {} } -result {Curiosity governs the first moment} testsuiteCleanup } finally { set done 1 }} after 0 coroutine [info cmdcount]_main main vwait [namespace current]::done |
Added modules/chan/getslimit.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # # ## ### ##### ######## ############# # copyright # # 2018 # # Poor Yorick # # ## ### ##### ######## ############# package require ego namespace eval ::tcllib::chan::getslimit { variable buf bufcount eof getslimit proc [namespace current] chan { if {![string match ::* $chan]} { set chan [uplevel 1 [list ::namespace which $chan]] } $chan .specialize foreach name { .init configure eof gets read } { $chan .method $name getslimit::$name } return $chan } proc .init {_ args} { $_ .vars eof buf bufcount getslimit set eof 0 set buf {} set bufcount 0 set getslimit -1 uplevel 1 [list $_ .prototype .init {*}$args] } proc configure {_ args} { $_ .vars getslimit if {[llength $args] == 1} { switch [lindex $args 0] { -getslimit { set res $getslimit } default { set res [uplevel 1 [list $_ .prototype configure {*}$args]] } } } elseif {[llength $args]} { dict size $args foreach {key val} $args[set args {}] { if {$key eq {-getslimit}} { set getslimit $val } else { lappend args $key $val } } if {[llength $args]} { uplevel 1 [list $_ .prototype configure {*}$args] } set res {} } else { set res [list {*}[uplevel 1 [ list $_ .prototype configure {*}$args]] -getslimit $getslimit] } return $res } proc eof _ { $_ .vars bufcount eof return [expr {$eof || ( [$_ .prototype eof] && $bufcount == 0 )}] } proc gets {_ args} { $_ .vars buf bufcount chan eof getslimit switch [llength $args] { 1 { lassign $args varname upvar 1 $varname resvar } 0 {} default { #this is just to generate the error message ::gets [$_ $ chan] {*}$args } } if {$eof} { if {[info exists varname]} { set resvar {} return -1 } return {} } if {[string first \n $buf] < 0 && ![::eof $chan]} { if {$getslimit >= 0} { append buf [$_ read $getslimit] } else { append buf [$_ read] } } if {[regexp {^(.*?)\n(.*)$} $buf -> res remainder]} { set buf $remainder set bufcount [expr {$bufcount - [string length $res] - 1}] } else { # must be at eof set res $buf set buf {} set bufcount 0 if {[::eof $chan]} { set eof 1 } } if {[llength $args]} { set args [lassign $args[set args {}] varname] set resvar $res if {$res eq {} && $eof} { return -1 } else { return [string length $res] } } else { return $res } } proc read {_ args} { $_ .vars buf eof bufcount if {$eof} { return {} } if {$bufcount} { if {[llength $args]} { lassign $args size if {$size <= $bufcount} { set res [string range $buf 0 [expr {$size - 1}]] set buf [string range $buf $size end] incr bufcount -[string length $res] } else { set readsize [expr {$size - $bufcount}] set res $buf[set buf {}][$_ .prototype read $readsize] set bufcount 0 } } else { set bufcount 0 set res $buf[set buf {}][$_ .prototype read {*}$args] } } else { set res [$_ .prototype read {*}$args] } return $res } } package provide tcllib::chan::getslimit 1 package provide {chan getslimit} 0.1 namespace eval ::tcllib::chan { namespace export getslimit } |
Added modules/chan/getslimit.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/tclsh source [file join \ [file dirname [file dirname [file dirname [ file normalize [info script]/...]]]]/devtools/testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2.0 package require {chan base} package require {chan getslimit} package require tcl::chan::memchan package require tcl::chan::string namespace import ::tcllib::chan::getslimit proc main {} { variable done set data1 abcdefghijklmnopqrstuvwxyz test getslimit-configure {} -body { ::tcllib::chan::base .new chan1 getslimit chan1 chan1 .init [::tcl::chan::memchan] -getslimit 33 chan1 configure -getslimit } -cleanup { rename chan1 {} } -result 33 test getslimit-under { } -body { ::tcllib::chan::base .new chan1 getslimit chan1 chan1 .init [::tcl::chan::string $data1] -getslimit 1000 chan1 gets } -cleanup { rename chan1 {} } -result $data1 test getslimit-exceeded { } -body { ::tcllib::chan::base .new chan1 getslimit chan1 chan1 .init [::tcl::chan::string [ string repeat $data1 100]] -getslimit 10 chan1 gets } -cleanup { rename chan1 {} } -result {abcdefghij} test getslimit-read { read is unaffacted by the limit } -body { ::tcllib::chan::base .new chan1 getslimit chan1 chan1 .init [::tcl::chan::string $data1] chan1 configure -getslimit 10 lappend res [chan1 read 15] lappend res [chan1 read 3] lappend res [chan1 read 1] lappend res [chan1 read] lappend res [chan1 eof] lappend res [chan1 read] lappend res [chan1 eof] } -cleanup { rename chan1 {} } -result {abcdefghijklmno pqr s tuvwxyz 1 {} 1} testsuiteCleanup set done 1 } after 0 coroutine [info cmdcount]_main main vwait [namespace current]::done |
Added modules/chan/pkgIndex.tcl.
> > > > > | 1 2 3 4 5 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded {chan getslimit} 0.1 [list ::source [file join $dir getslimit.tcl]] package ifneeded {chan base} 0.1 [list ::source [file join $dir base.tcl]] package ifneeded {chan coroutine} 0.1 [list ::source [file join $dir coroutine.tcl]] |
Changes to modules/clay/build/build.tcl.
1 2 3 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] | | | 1 2 3 4 5 6 7 8 9 10 11 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] set version 0.7 set module clay set filename clay if {[file exists [file join $moddir .. .. scripts practcl.tcl]]} { source [file join $moddir .. .. scripts practcl.tcl] } elseif {[file exists [file join $moddir .. practcl build doctool.tcl]]} { source [file join $moddir .. practcl build doctool.tcl] } else { |
︙ | ︙ | |||
60 61 62 63 64 65 66 67 68 69 70 71 72 73 | lappend loaded build.tcl test.tcl foreach file { procs.tcl core.tcl uuid.tcl dict.tcl list.tcl dictargs.tcl dialect.tcl metaclass.tcl ensemble.tcl class.tcl object.tcl } { lappend loaded $file set content [::practcl::cat [file join $srcdir {*}$file]] | > | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | lappend loaded build.tcl test.tcl foreach file { procs.tcl core.tcl uuid.tcl dict.tcl list.tcl dictargs.tcl dialect.tcl dictargs.tcl metaclass.tcl ensemble.tcl class.tcl object.tcl } { lappend loaded $file set content [::practcl::cat [file join $srcdir {*}$file]] |
︙ | ︙ |
Changes to modules/clay/build/class.tcl.
1 2 3 4 5 6 7 8 9 | ::oo::define ::clay::class { ### # description: # The [method clay] method allows a class object access # to a combination of its own clay data as # well as to that of its ancestors # ensemble: # ancestors { | | | | | | | | | | | 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 | ::oo::define ::clay::class { ### # description: # The [method clay] method allows a class object access # to a combination of its own clay data as # well as to that of its ancestors # ensemble: # ancestors { # arglist {} # description {Return this class and all ancestors in search order.} # } # dump { # arglist {} # description {Return a complete dump of this object's clay data, but only this object's clay data.} # } # find { # arglist {path {mandatory 1 positional 1 repeating 1}} # description { # Pull a chunk of data from the clay system. If the last element of [emph path] is a branch, # returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. # If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching # leaf and return the first value found. # If no value is found, returns an empty string. # If a branch is returned the topmost . entry is omitted. # } # } # get { # arglist {path {mandatory 1 positional 1 repeating 1}} # description { # Pull a chunk of data from the class's clay system. # If no value is found, returns an empty string. # If a branch is returned the topmost . entry is omitted. # } # } # GET { # arglist {path {mandatory 1 positional 1 repeating 1}} # description { # Pull a chunk of data from the class's clay system. # If no value is found, returns an empty string. # } #} # merge { # arglist {dict {mandatory 1 positional 1 repeating 1}} # description {Recursively merge the dictionaries given into the object's local clay storage.} # } # replace { # arglist {dictionary {mandatory 1 positional 1}} # description {Replace the contents of the internal clay storage with the dictionary given.} # } # search { # arglist {path {mandatory 1 positional 1 repeating 1}} # description {Return the first matching value for the path in either this class's clay data or one of its ancestors} # } # set { # arglist {path {mandatory 1 positional 1 repeating 1} value {mandatory 1 postional 1}} # description {Merge the conents of [const value] with the object's clay storage at [const path].} # } ### method clay {submethod args} { my variable clay if {![info exists clay]} { set clay {} |
︙ | ︙ |
Changes to modules/clay/build/core.tcl.
1 | package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. | < | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 | package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. package require TclOO package require md5 2 ::namespace eval ::clay {} ::namespace eval ::clay::classes {} ::namespace eval ::clay::define {} ::namespace eval ::clay::tree {} ::namespace eval ::clay::dict {} ::namespace eval ::clay::list {} ::namespace eval ::clay::uuid {} |
Changes to modules/clay/build/dialect.tcl.
1 2 | ### # Adapted from Tcllib's oo::dialect | < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ### # Adapted from Tcllib's oo::dialect ### namespace eval ::clay::dialect { namespace export create # Allow test rigs to overwrite the flags before invoking this script foreach {flag test} { tip470 {package vsatisfies [package provide Tcl] 8.7} } { if {![info exists ::clay::dialect::has($flag)]} { set ::clay::dialect::has($flag) [eval $test] } } } proc ::clay::dialect::Push {class} { ::variable class_stack lappend class_stack $class } proc ::clay::dialect::Peek {} { ::variable class_stack |
︙ | ︙ |
Changes to modules/clay/build/dictargs.tcl.
︙ | ︙ | |||
20 21 22 23 24 25 26 | set found 1 break } } if {$found} continue } if {[dict exists $info default:]} { | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | set found 1 break } } if {$found} continue } if {[dict exists $info default:]} { set _var [dict get $info default:] \n continue } set mandatory 1 if {[dict exists $info mandatory:]} { set mandatory [dict get $info mandatory:] } if {$mandatory} { |
︙ | ︙ |
Changes to modules/clay/build/ensemble.tcl.
1 2 | ::namespace eval ::clay::define {} | < < < < < < < < < < < < < > > > > > > > > > | > | > | > > | | > > | | < > | > > | > | > > | < | > > > > > | | < < < < < < < < | > | | > > > | < < < < | < < < | | < | < | | | | > < < < | | < | < > > | < < | 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 | ::namespace eval ::clay::define {} proc ::clay::ensemble_methodbody {ensemble einfo} { set default standard set preamble {} set eswitch {} if {[dict exists $einfo default]} { set emethodinfo [dict get $einfo default] set arglist [dict getnull $emethodinfo arglist] set realbody [dict get $emethodinfo body] if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} { set body {} } else { set body "\n ::clay::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args" } append body "\n " [string trim $realbody] " \n" set default $body dict unset einfo default } foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] { set submethod [string trim $msubmethod :/-] if {$submethod eq "_body"} continue if {$submethod eq "_preamble"} { set preamble [dict getnull $esubmethodinfo body] continue } set arglist [dict getnull $esubmethodinfo arglist] set realbody [dict getnull $esubmethodinfo body] if {[string length [string trim $realbody]] eq {}} { dict set eswitch $submethod {} } else { if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} { set body {} } else { set body "\n ::clay::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args" } append body "\n " [string trim $realbody] " \n" if {$submethod eq "default"} { set default $body } else { foreach alias [dict getnull $esubmethodinfo aliases] { dict set eswitch $alias - } dict set eswitch $submethod $body } } } set methodlist [lsort -dictionary [dict keys $eswitch]] if {![dict exists $eswitch <list>]} { dict set eswitch <list> {return $methodlist} } if {$default eq "standard"} { set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\"" } dict set eswitch default $default set mbody {} append mbody $preamble \n append mbody \n [list set methodlist $methodlist] append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]" append mbody \n {return -options $opts $result} return $mbody } ::proc ::clay::define::Ensemble {rawmethod arglist body} { set class [current_class] #if {$::clay::trace>2} { # puts [list $class Ensemble $rawmethod $arglist $body] #} set mlist [split $rawmethod "::"] set ensemble [string trim [lindex $mlist 0] :/] set mensemble ${ensemble}/ if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} { set method _body ### # Simple method, needs no parsing, but we do need to record we have one ### $class clay set method_ensemble/ $mensemble _body [dict create arglist $arglist body $body] if {$::clay::trace>2} { puts [list $class clay set method_ensemble/ $mensemble _body ...] } set method $rawmethod if {$::clay::trace>2} { puts [list $class Ensemble $rawmethod $arglist $body] set rawbody $body set body {puts [list [self] $class [self method]]} append body \n $rawbody } ::oo::define $class method $rawmethod $arglist $body return } set method [join [lrange $mlist 2 end] "::"] $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create arglist $arglist body $body] if {$::clay::trace>2} { puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/] ...] } } |
Changes to modules/clay/build/footer.txt.
1 | [vset CATEGORY oo] | | | 1 2 | [vset CATEGORY oo] [include ../doctools2base/include/feedback.inc] |
Changes to modules/clay/build/metaclass.tcl.
︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 118 | proc ::clay::define::destructor rawbody { set body { # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 } append body $rawbody ::oo::define [current_class] destructor $body } proc ::clay::define::Dict {name {values {}}} { set class [current_class] | > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | proc ::clay::define::destructor rawbody { set body { # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 ::clay::object_destroy $self } append body $rawbody ::oo::define [current_class] destructor $body } proc ::clay::define::Dict {name {values {}}} { set class [current_class] |
︙ | ︙ | |||
149 150 151 152 153 154 155 | } } foreach {f v} $dictargs { $class clay set option $name $f $v } } | < < < < < < < < < < < < | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | } } foreach {f v} $dictargs { $class clay set option $name $f $v } } ### # Define a class of options # All field / value pairs will be be inherited by an option that # specify [emph name] as it class field. ### proc ::clay::define::Option_Class {name args} { set class [current_class] |
︙ | ︙ | |||
190 191 192 193 194 195 196 | # (if missing) when the object changes class via the [emph morph] method. ### proc ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } | > > > > > > > > > > > > > > > > > > > > | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | # (if missing) when the object changes class via the [emph morph] method. ### proc ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } proc ::clay::object_create {objname {class {}}} { #if {$::clay::trace>0} { # puts [list $objname CREATE] #} } proc ::clay::object_rename {object newname} { if {$::clay::trace>0} { puts [list $object RENAME -> $newname] } } proc ::clay::object_destroy objname { if {$::clay::trace>0} { puts [list $objname DESTROY] } ::cron::object_destroy $objname } |
Changes to modules/clay/build/object.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # clay::object # # This class is inherited by all classes that have options. # ::oo::define ::clay::object { ### # description: # The [method clay] method allows an object access # to a combination of its own clay data as # well as to that of its class # ensemble: # ancestors { | | < < < < | | | | | | | | | | | | | | | | < < < < | | < < < < < < < < < | < < < < < < < < < < < < < < < < | 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 | # clay::object # # This class is inherited by all classes that have options. # ::oo::define ::clay::object { ### # description: # The [method clay] method allows an object access # to a combination of its own clay data as # well as to that of its class # ensemble: # ancestors { # arglist {} # description {Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.} # } # cget { # arglist {field {mandatory 1 positional 1}} # description { # Pull a value from either the object's clay structure or one of its constituent classes that matches the field name. # The order of search us: # [para] 1. The as a value in local dict variable config # [para] 2. The as a value in local dict variable clay # [para] 3. As a leaf in any ancestor as a root of the clay tree # [para] 4. As a leaf in any ancestor as [const const] [emph field] # [para] 5. As a leaf in any ancestor as [const option] [emph field] [const default] # } # } # delegate { # arglist {stub {mandatory 0 positional 1} object {mandatory 0 positional 1}} # description { # Introspect or control method delegation. With no arguments, the method will return a # key/value list of stubs and objects. With just the [arg stub] argument, the method will # return the object (if any) attached to the stub. With a [arg stub] and an [arg object] # this command will forward all calls to the method [arg stub] to the [arg object]. # } # } # dump { arglist {} description {Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in.}} # ensemble_map {arglist {} description {Return a dictionary describing the method ensembles to be assembled for this object}} # eval {arglist {script {mandatory 1 positional 1}} description {Evaluated a script in the namespace of this object}} # evolve {arglist {} description {Trigger the [method InitializePublic] private method}} # exists {arglist {path {mandatory 1 positional 1 repeating 1}} description {Returns 1 if [emph path] exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found.}} # flush {arglist {} description {Wipe any caches built by the clay implementation}} # forward {arglist {method {positional 1 mandatory 1} object {positional 1 mandatory 1}} description {A convenience wrapper for # [example {oo::objdefine [self] forward {*}$args}] # } # } # get {arglist {path {mandatory 1 positional 1 repeating 1}} # description {Pull a chunk of data from the clay system. If the last element of [emph path] is a branch (ends in a slash /), # returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. # If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching # leaf and return the first value found. # If no value is found, returns an empty string. # } # } # leaf {arglist {path {mandatory 1 positional 1 repeating 1}} description {A modified get which is tailored to pull only leaf elements}} # merge {arglist {dict {mandatory 1 positional 1 repeating 1}} description {Recursively merge the dictionaries given into the object's local clay storage.}} # mixin {arglist {class {mandatory 1 positional 1 repeating 1}} description { # Perform [lb]oo::objdefine [lb]self[rb] mixin[rb] on this object, with a few additional rules: # Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.) # For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.) # Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.) # }} # mixinmap { # arglist {stub {mandatory 0 positional 1} classes {mandatory 0 positional 1}} # description {With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given, # returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given # classes and invoke clay mixin on the new matrix of mixed in classes. # } # } # provenance {arglist {path {mandatory 1 positional 1 repeating 1}} description {Return either [const self] if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element.}} # replace {arglist {dictionary {mandatory 1 positional 1}} description {Replace the contents of the internal clay storage with the dictionary given.}} # source {arglist {filename {mandatory 1 positional 1}} description {Source the given filename within the object's namespace}} # set {arglist {path {mandatory 1 positional 1 repeating 1} value {mandatory 1 postional 1}} description {Merge the conents of [const value] with the object's clay storage at [const path].}} ### method clay {submethod args} { my variable clay claycache clayorder config option_canonical if {![info exists clay]} {set clay {}} if {![info exists claycache]} {set claycache {}} if {![info exists config]} {set config {}} if {![info exists clayorder] || [llength $clayorder]==0} { set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] } switch $submethod { ancestors { return $clayorder } branch { set path [::clay::tree::storage $args] if {![dict exists $clay {*}$path .]} { dict set clay {*}$path . {} } } cget { # Leaf searches return one data field at a time # Search in our local dict if {[llength $args]==1} { set field [string trim [lindex $args 0] -:/] if {[info exists option_canonical($field)]} { set field $option_canonical($field) |
︙ | ︙ | |||
203 204 205 206 207 208 209 | foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } ensemble_map { | | > > | | | < < < < < < < < < < < < < < < < < < < < | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } ensemble_map { set ensemble [lindex $args 0] my variable claycache set mensemble [string trim $ensemble :/] if {[dict exists $claycache method_ensemble $mensemble]} { return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]] } set emap [my clay dget method_ensemble $mensemble] dict set claycache method_ensemble $mensemble $emap return [clay::tree::sanitize $emap] } eval { set script [lindex $args 0] set buffer {} set thisline {} foreach line [split $script \n] { append thisline $line |
︙ | ︙ | |||
301 302 303 304 305 306 307 308 309 310 311 | # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } | > > > > > > > < < < < < | | > > > > > > > < < < < < < < < | | < | | < < | > > | < | 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 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 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 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 | # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [dict get $claycache {*}$path] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result [dict getnull $clay {*}$path] foreach class $clayorder { if {![$class clay exists {*}$path .]} continue ::clay::tree::dictmerge result [$class clay dget {*}$path] } #if {[dict exists $clay {*}$path .]} { # ::clay::tree::dictmerge result #} dict set claycache {*}$path $result return $result } getnull - get { set path [::clay::tree::storage $args] if {[llength $path]==0} { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return [::clay::tree::sanitize $result] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [::clay::tree::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result [dict getnull $clay {*}$path] #foreach class [lreverse $clayorder] { # if {![$class clay exists {*}$path .]} continue # ::clay::tree::dictmerge result [$class clay dget {*}$path] #} foreach class $clayorder { if {![$class clay exists {*}$path .]} continue ::clay::tree::dictmerge result [$class clay dget {*}$path] } #if {[dict exists $clay {*}$path .]} { # ::clay::tree::dictmerge result [dict get $clay {*}$path] #} dict set claycache {*}$path $result return [clay::tree::sanitize $result] } leaf { # Leaf searches return one data field at a time # Search in our local dict set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path .]} { return [clay::tree::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [clay::tree::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } } } merge { foreach arg $args { ::clay::tree::dictmerge clay {*}$arg } } mixin { ### # Mix in the class ### set prior [info object mixins [self]] set newmixin {} foreach item $args { lappend newmixin ::[string trimleft $item :] } set newmap $args foreach class $prior { |
︙ | ︙ | |||
469 470 471 472 473 474 475 476 477 478 479 480 481 482 | puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" } break } } } mixinmap { if {![dict exists $clay .mixin]} { dict set clay .mixin {} } if {[llength $args]==0} { return [dict get $clay .mixin] } elseif {[llength $args]==1} { return [dict getnull $clay .mixin [lindex $args 0]] | > | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 | puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" } break } } } mixinmap { my variable clay if {![dict exists $clay .mixin]} { dict set clay .mixin {} } if {[llength $args]==0} { return [dict get $clay .mixin] } elseif {[llength $args]==1} { return [dict getnull $clay .mixin [lindex $args 0]] |
︙ | ︙ | |||
500 501 502 503 504 505 506 | foreach class $clayorder { if {[$class clay exists {*}$args]} { return $class } } return {} } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | < < < < < | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 | foreach class $clayorder { if {[$class clay exists {*}$args]} { return $class } } return {} } replace { set clay [lindex $args 0] } source { source [lindex $args 0] } set { #puts [list [self] clay SET {*}$args] set claycache {} ::clay::tree::dictset clay {*}$args } default { dict $submethod clay {*}$args } } } ### # Instantiate variables. Called on object creation and during clay mixin. ### method InitializePublic {} { my variable clayorder clay claycache config option_canonical set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] if {![info exists clay]} { set clay {} } if {![info exists config]} { set config {} |
︙ | ︙ | |||
619 620 621 622 623 624 625 | } dict set config $field $value set setcmd [dict getnull $info set-command] if {$setcmd ne {}} { {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd] } } | > > > > > | > > > > > > > > > > > > > > > > > > > > > > | < | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 | } dict set config $field $value set setcmd [dict getnull $info set-command] if {$setcmd ne {}} { {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd] } } my variable clayorder clay claycache if {[info exists clay]} { set emap [dict getnull $clay method_ensemble] } else { set emap {} } foreach class [lreverse $clayorder] { ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### dict for {mensemble einfo} [$class clay get method_ensemble] { if {$mensemble eq {.}} continue set ensemble [string trim $mensemble :/] if {$::clay::trace>2} {puts [list Defining $ensemble from $class]} dict for {method info} $einfo { if {$method eq {.}} continue if {![dict is_dict $info]} { puts [list WARNING: class: $class method: $method not dict: $info] continue } dict set info source $class if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]} dict set emap $ensemble $method $info } } } foreach {ensemble einfo} $emap { #if {[dict exists $einfo _body]} continue set body [::clay::ensemble_methodbody $ensemble $einfo] if {$::clay::trace>2} { set rawbody $body set body {puts [list [self] <object> [self method]]} append body \n $rawbody } oo::objdefine [self] method $ensemble {{method default} args} $body |
︙ | ︙ |
Changes to modules/clay/build/procs.tcl.
1 2 3 | namespace eval ::clay {} set ::clay::trace 0 | < < < < < < | 1 2 3 4 5 6 7 8 9 10 | namespace eval ::clay {} set ::clay::trace 0 ### # Because many features in this package may be added as # commands to future tcl cores, or be provided in binary # form by packages, I need a declaritive way of saying # [emph {Create this command if there isn't one already}]. # The [emph ninja] argument is a script to execute if the # command is created by this mechanism. |
︙ | ︙ | |||
203 204 205 206 207 208 209 | # a handy default for method delegation if a delegate has not been # assigned yet. proc ::clay::noop args {} if {[info commands ::noop] eq {}} { namespace eval ::clay { namespace export noop } namespace eval :: { namespace import ::clay::noop } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 | # a handy default for method delegation if a delegate has not been # assigned yet. proc ::clay::noop args {} if {[info commands ::noop] eq {}} { namespace eval ::clay { namespace export noop } namespace eval :: { namespace import ::clay::noop } } proc ::clay::path args { set result {} foreach item $args { set item [string trim $item :./] foreach subitem [split $item /] { lappend result [string trim ${subitem}]/ |
︙ | ︙ |
Changes to modules/clay/build/test.tcl.
︙ | ︙ | |||
717 718 719 720 721 722 723 | clay set const/flavor strawberry clay set {const/ sound} zoink clay set info/ { animal no building no subelement {pedantic yes} } | < < < < < < < < < < < < | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 | clay set const/flavor strawberry clay set {const/ sound} zoink clay set info/ { animal no building no subelement {pedantic yes} } } set claydict-a { const/ {color blue flavor strawberry sound zoink} info/ { animal no building no subelement {pedantic yes} |
︙ | ︙ | |||
778 779 780 781 782 783 784 | const/ {color black flavor vanilla feeling dread} info/ {subelement {spoon yes}} } set commands-b {} foreach {top children} ${claydict-b} { foreach {child value} $children { putb commands-b " [list clay set $top $child $value]" | < | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 | const/ {color black flavor vanilla feeling dread} info/ {subelement {spoon yes}} } set commands-b {} foreach {top children} ${claydict-b} { foreach {child value} $children { putb commands-b " [list clay set $top $child $value]" } } putb result [list %class% ${class-b} %commands% ${commands-b}] { clay::define %class% { %commands% } } |
︙ | ︙ | |||
829 830 831 832 833 834 835 | } ### # Tests for objects ### putb result {# ------------------------------------------------------------------------- | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | } ### # Tests for objects ### putb result {# ------------------------------------------------------------------------- # OBJECT of ::foo::classa set OBJECTA [::foo::classa new] ### # Test object degation ### proc ::foo::fakeobject {a b} { |
︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 | test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } | < < < < < < < < < < | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 | test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } } } putb result {# ------------------------------------------------------------------------- # OBJECT of ::foo::classb set OBJECTB [::foo::classb new] # Object with ::foo::classb mixed in |
︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } | < < < < < < < < < < | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 | test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } } } putb result {# ------------------------------------------------------------------------- # OBJECT descended from ::foo::classa ::foo::classb set OBJECTAB [::foo::class.ab new] # Object where classes were mixed in ::foo::classa ::foo::classb |
︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } | < < < < < < < < < < | 947 948 949 950 951 952 953 954 955 956 957 958 959 960 | test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } } } putb result {# ------------------------------------------------------------------------- # OBJECT descended from ::foo::classb ::foo::classa set OBJECTBA [::foo::class.ba new] # Object where classes were mixed in ::foo::classb ::foo::classa |
︙ | ︙ | |||
1138 1139 1140 1141 1142 1143 1144 | test oo-object-clay-method-native-%testnum% {Test native object gets the property} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property} { $%object2% clay get %top% %child% } {%value%} } | < < < < < < < < < < < | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 | test oo-object-clay-method-native-%testnum% {Test native object gets the property} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property} { $%object2% clay get %top% %child% } {%value%} } } } putb resut { ### # Test local setting if clay data in an object ### |
︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 | method do args { return "I did $args" } Ensemble which::color {} { return [my clay get color] } | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 | method do args { return "I did $args" } Ensemble which::color {} { return [my clay get color] } clay set method_ensemble which color aliases farbe } ### # Test clay information is passed town to subclasses ### test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclasse clay get color |
︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 | $OBJ3 which color } black # Test setting properties test clay-object-method-0004 {Test an ensemble alias} { $OBJ3 which farbe } black | < < < < < < < < < < < < < < < < < < < < < < | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 | $OBJ3 which color } black # Test setting properties test clay-object-method-0004 {Test an ensemble alias} { $OBJ3 which farbe } black ### # Test that if you try to replace a global command you get an error ### test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body { ::clay::define open { method bar {} { return foo } |
︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 | test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} { info commands ::clay::pot } {::clay::pot} #set ::clay::trace 3 ### | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 | test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} { info commands ::clay::pot } {::clay::pot} #set ::clay::trace 3 ### # Mixin tests ### ### # Define a core class ### ::clay::define ::TEST::thing { |
︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 | Ensemble which::flavor {} { return [my clay get flavor] } Ensemble which::color {} { return [my clay get color] } | < < < < < < | < < < | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 | Ensemble which::flavor {} { return [my clay get flavor] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::animal { clay color unknown clay sound unknown Ensemble which::sound {} { return [my clay get sound] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::species.cat { superclass ::TEST::animal clay sound meow } ::clay::define ::TEST::coloring.calico { clay color calico } ::clay::define ::TEST::condition.dark { Ensemble which::color {} { return grey } } ::clay::define ::TEST::mood.happy { Ensemble which::sound {} { return purr } } test clay-object-0001 {Test than an object is created when clay::define is invoked} { info commands ::TEST::mood.happy } ::TEST::mood.happy set OBJ [::TEST::thing new] test clay-mixin-a-0001 {Test that prior to a mixin an ensemble doesn't exist} -body { |
︙ | ︙ | |||
1507 1508 1509 1510 1511 1512 1513 | test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {unknown} | < < | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 | test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {unknown} test clay-mixin-b-0003 {Test that an ensemble is created during a mixin} \ -body {$OBJ which flavor} -returnCodes {error} \ -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-21 ### test clay-mixin-b-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::animal ::TEST::thing ::clay::object} |
︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 | ### # Replacing a mixin $OBJ clay mixinmap species ::TEST::species.cat test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} | < < < < < < | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 | ### # Replacing a mixin $OBJ clay mixinmap species ::TEST::species.cat test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} \ -body {$OBJ which flavor} -returnCodes {error} \ -result {unknown method which flavor. Valid: color sound} ### |
︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 | set ensemble [self method] set emap [my clay ensemble_map $ensemble] set mlist [dict keys $emap [string tolower $pattern]] if {[llength $mlist] != 1} { error "Couldn't figure out what to do with $pattern" } set method [lindex $mlist 0] | | | | | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 | set ensemble [self method] set emap [my clay ensemble_map $ensemble] set mlist [dict keys $emap [string tolower $pattern]] if {[llength $mlist] != 1} { error "Couldn't figure out what to do with $pattern" } set method [lindex $mlist 0] set arglist [dict get $emap $method arglist] set body [dict get $emap $method body] if {$arglist ni {args {}}} { ::clay::dynamic_arguments $ensemble $method [list $arglist] {*}$args } eval $body } Ensemble myensemble::go args { return 1 } |
︙ | ︙ | |||
2466 2467 2468 2469 2470 2471 2472 | {clay ancestors} {::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 | {clay ancestors} {::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } ### # TESTS NEEDED: # destructor ### |
︙ | ︙ |
Changes to modules/clay/build/uuid.tcl.
︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt # # uuid: scheme: # http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html # # Usage: clay::uuid generate # clay::uuid equal $idA $idB namespace eval ::clay::uuid { namespace export uuid } ### # Optimization # Caches machine info after the first pass ### | > > > > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt # # uuid: scheme: # http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html # # Usage: clay::uuid generate # clay::uuid equal $idA $idB package require Tcl 8.5 namespace eval ::clay::uuid { namespace export uuid variable uid if {![info exists uid]} { set uid 1 } } ### # Optimization # Caches machine info after the first pass ### |
︙ | ︙ | |||
69 70 71 72 73 74 75 | } return $machinfo } # Generates a binary UUID as per the draft spec. We generate a pseudo-random # type uuid (type 4). See section 3.4 # | < | | < < < | < < < < > > | | | < < < < < < < | < | | < > > | < < | < | > > | > | < < < | 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 | } return $machinfo } # Generates a binary UUID as per the draft spec. We generate a pseudo-random # type uuid (type 4). See section 3.4 # proc ::clay::uuid::generate {} { variable uid set tok [md5::MD5Init] md5::MD5Update $tok [incr uid]; # package incrementing counter foreach string [generate_tcl_machinfo] { md5::MD5Update $tok $string } set r [md5::MD5Final $tok] binary scan $r c* r # 3.4: set uuid versioning fields lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] return [binary format c* $r] } # Convert a binary uuid into its string representation. # proc ::clay::uuid::tostring {uuid} { binary scan $uuid H* s foreach {a b} {0 7 8 11 12 15 16 19 20 end} { append r [string range $s $a $b] - } return [string tolower [string trimright $r -]] } # Convert a string representation of a uuid into its binary format. # proc ::clay::uuid::fromstring {uuid} { return [binary format H* [string map {- {}} $uuid]] } # Compare two uuids for equality. # proc ::clay::uuid::equal {left right} { set l [fromstring $left] set r [fromstring $right] return [string equal $l $r] } # uuid generate -> string rep of a new uuid # uuid equal uuid1 uuid2 # proc ::clay::uuid {cmd args} { switch -exact -- $cmd { generate { tailcall ::clay::uuid::tostring [::clay::uuid::generate] } equal { tailcall ::clay::uuid::equal {*}$args } default { return -code error "bad option \"$cmd\":\ must be generate or equal" } } } |
Changes to modules/clay/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.6]} {return} | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded clay 0.7 [list source [file join $dir clay.tcl]] |
Changes to modules/cmdline/cmdline.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal cmdline.tcl cmdline } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/cmdline/typedCmdline.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal cmdline.tcl cmdline } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/comm/comm.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # All rights reserved. # ------------------------------------------------------------------------- source [file join [file dirname [file dirname [ file join [pwd] [info script]]]] devtools testutilities.tcl] | < | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # All rights reserved. # ------------------------------------------------------------------------- source [file join [file dirname [file dirname [ file join [pwd] [info script]]]] devtools testutilities.tcl] testsNeedTcl 8.5 ; # snit testsNeedTcltest 1.0 tcltest::testConstraint hastls [expr {![catch {package require tls}]}] support { # Using snit1 here, whatever the version of Tcl use snit/snit.tcl snit |
︙ | ︙ |
Changes to modules/control/do.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # do.test -- # # Tests for [control::do] # # RCS: @(#) $Id: do.test,v 1.14 2009/11/24 04:52:49 andreas_kupries Exp $ # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # do.test -- # # Tests for [control::do] # # RCS: @(#) $Id: do.test,v 1.14 2009/11/24 04:52:49 andreas_kupries Exp $ # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal control.tcl control } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/control/no-op.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal control.tcl control } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/counter/counter.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal counter.tcl counter } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/crc/cksum.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal cksum.tcl cksum ::crc } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/crc/crc16.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal crc16.tcl crc16 ::crc } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/crc/crc32.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal crc32.tcl crc32 ::crc } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/crc/crc32bugs.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::crc} support { useLocal crc16.tcl crc16 } testing { |
︙ | ︙ |
Changes to modules/crc/sum.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testing { useLocal sum.tcl sum ::crc } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/cron/cron.tcl.
1 2 3 4 5 6 7 8 9 | ### # This file implements a process table # Instead of having individual components try to maintain their own timers # we centrally manage how often tasks should be kicked off here. ### # # Author: Sean Woods (for T&E Solutions) package require Tcl 8.6 ;# See coroutine package require coroutine | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | ### # This file implements a process table # Instead of having individual components try to maintain their own timers # we centrally manage how often tasks should be kicked off here. ### # # Author: Sean Woods (for T&E Solutions) package require Tcl 8.6 ;# See coroutine package require coroutine package provide cron 2.1.1 ::namespace eval ::cron {} proc ::cron::task {command args} { if {$::cron::trace > 1} { puts [list ::cron::task $command $args] } variable processTable |
︙ | ︙ | |||
262 263 264 265 266 267 268 | } proc ::cron::once_in_a_while body { set script {set _eventid_ $::cron::current_event} append script $body # Add a safety to allow this while to only execute once per call append script {if {$_eventid_==$::cron::current_event} yield} | | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 | } proc ::cron::once_in_a_while body { set script {set _eventid_ $::cron::current_event} append script $body # Add a safety to allow this while to only execute once per call append script {if {$_eventid_==$::cron::current_event} yield} uplevel 1 [list while 1 $script] } proc ::cron::sleep ms { if {$::cron::trace > 1} { puts [list ::cron::sleep $ms [info coroutine]] } |
︙ | ︙ | |||
397 398 399 400 401 402 403 | foreach task $tasks { dict set processTable($task) lastrun $now if {[dict exists processTable($task) foreground] && [dict set processTable($task) foreground]} continue if {[dict exists processTable($task) running] && [dict set processTable($task) running]} continue if {$::cron::trace > 2} { puts [list RUNNING $task [task info $task]] } | | > > > > | > > > > | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 | foreach task $tasks { dict set processTable($task) lastrun $now if {[dict exists processTable($task) foreground] && [dict set processTable($task) foreground]} continue if {[dict exists processTable($task) running] && [dict set processTable($task) running]} continue if {$::cron::trace > 2} { puts [list RUNNING $task [task info $task]] } if {[dict exists $processTable($task) coroutine]} { set coro [dict get $processTable($task) coroutine] } else { set coro {} } dict set processTable($task) running 1 if {[dict exists $processTable($task) command]} { set command [dict get $processTable($task) command] } else { set command {} } if {$command eq {} && $coro eq {}} { # Task has nothing to do. Slot it for destruction lappend cancellist $task } elseif {$coro ne {}} { if {[info command $coro] eq {}} { set object [dict get $processTable($task) object] # Trigger coroutine again if a command was given |
︙ | ︙ | |||
611 612 613 614 615 616 617 | idle 0 wake 0 } } } ::cron::wake STARTUP | < | 621 622 623 624 625 626 627 628 | idle 0 wake 0 } } } ::cron::wake STARTUP |
Changes to modules/cron/cron.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | devtools testutilities.tcl] package require tcltest testsNeedTcl 8.6 testsNeedTcltest 1.0 support { | < | | 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 | devtools testutilities.tcl] package require tcltest testsNeedTcl 8.6 testsNeedTcltest 1.0 support { } testing { useLocal cron.tcl cron } ### # For the first part of our testing, control the clock # via the test harness ### set ::cron::trace 0 set ::cron::time [expr {[clock scan {2016-01-01}]*1000}] foreach {val testval} { 1000 1000 11235 11000 1241241 1241000 } { test cron-step-$val [list test clock_step function for $val] { ::cron::clock_step $val } $testval } proc test_elapsed_time {start target} { set now [::cron::current_time] set value [expr {$now-$start}] if {$value < ($target-5)} { puts "ELAPSED TIME WAS SHORT: $value / $target" |
︙ | ︙ | |||
210 211 212 213 214 215 216 | method exit_loop {} { my variable doloop set doloop 0 if {$::cron::trace} { puts [list [self] SIGNAL TO EXIT] } } | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | method exit_loop {} { my variable doloop set doloop 0 if {$::cron::trace} { puts [list [self] SIGNAL TO EXIT] } } method DoLoop {} { if {$::cron::trace} { puts "[self] CORO START" } my variable doloop set doloop 1 set ::TESTOBJ([self]) 0 |
︙ | ︙ | |||
358 359 360 361 362 363 364 | set delay [expr {($::my_coro_end - $::my_coro_start)}] if {$delay < 1000 || $delay > 2000} { puts "TIME DELAY OUT OF RANGE: $delay" return 1 } else { return 0 } | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | set delay [expr {($::my_coro_end - $::my_coro_start)}] if {$delay < 1000 || $delay > 2000} { puts "TIME DELAY OUT OF RANGE: $delay" return 1 } else { return 0 } } 0 ### # Tests after this point test interactions with the Tcl event loop # We need to be slaved to the real time clock to work properly ### set ::cron::trace 0 |
︙ | ︙ |
Changes to modules/cron/pkgIndex.tcl.
1 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} | | | 1 2 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded cron 2.1.1 [list source [file join $dir cron.tcl]] |
Changes to modules/csv/csv.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use struct/queue.tcl struct::queue use struct/matrix.tcl struct::matrix } testing { |
︙ | ︙ |
Changes to modules/des/des.test.
︙ | ︙ | |||
18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { # Base implementation first, then the package for the public API useLocal [expr { [tcltest::testConstraint no3des] ? "tcldesjr.tcl" : |
︙ | ︙ |
Changes to modules/devtools/testutilities.tcl.
︙ | ︙ | |||
48 49 50 51 52 53 54 | # Note that this command will try to load a suitable version of # Tcltest if the package has not been loaded yet. regexp {^([^-]*)} $version -> minversion if {[lsearch [namespace children] ::tcltest] == -1} { | | | > > > > > > > > | | 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 | # Note that this command will try to load a suitable version of # Tcltest if the package has not been loaded yet. regexp {^([^-]*)} $version -> minversion if {[lsearch [namespace children] ::tcltest] == -1} { if {[catch { package require tcltest $version } cres copts]} { set msg [dict get $copts -errorinfo] } else { namespace import -force ::tcltest::* InitializeTclTest return } } elseif {[package vcompare [package present tcltest] $minversion] >= 0} { InitializeTclTest return } if {![info exists msg]} { set msg " Requiring at least tcltest $version, have [ package present tcltest]" } puts " Aborting the tests found in [file tail [info script]]." puts $msg # This causes a 'return' in the calling scope. return -code return } proc testsNeed {name {version {}}} { # This command ensures that a minimum version of package <name> is |
︙ | ︙ |
Added modules/dicttool/build/build.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] set version 1.2 set module dicttool set filename dicttool if {[file exists [file join $moddir .. practcl build doctool.tcl]]} { source [file join $moddir .. practcl build doctool.tcl] } else { package require practcl 0.13 } ::practcl::doctool create AutoDoc set fout [open [file join $moddir ${filename}.tcl] w] dict set modmap %module% $module dict set modmap %version% $version dict set modmap %license% BSD dict set modmap %filename% $filename set authors {{Sean Woods} {<[email protected]>}} puts $fout [string map $modmap {### # %filename%.tcl # # Copyright (c) 2018 Sean Woods # # BSD License ### # @@ Meta Begin # Package %module% %version% # Meta platform tcl # Meta summary Enhancements to the dict command to support recursive merging # Meta description This package adds several list commands and dict commands which # Meta description developers find themselves implementing over and over again. # Meta description In addition it provides tools to manage recursive dicts in a # Meta description clean (and thoroughly regression tested) format. # Meta category dict # Meta subject dict # Meta require {Tcl 8.5}}] foreach {name email} $authors { puts $fout "# Meta author $name" } puts $fout [string map $modmap {# Meta license %license% # @@ Meta End }] puts $fout [string map $modmap {### # Amalgamated package for %module% # Do not edit directly, tweak the source in build/ and rerun # build.tcl ### package provide %module% %version% namespace eval ::%module% {} }] # Track what files we have included so far set loaded {} lappend loaded build.tcl test.tcl # These files must be loaded in a particular order foreach file { core.tcl } { lappend loaded $file set content [::practcl::cat [file join $srcdir {*}$file]] AutoDoc scan_text $content puts $fout "###\n# START: [file tail $file]\n###" puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # These files can be loaded in any order foreach file [lsort -dictionary [glob [file join $srcdir *.tcl]]] { if {[file tail $file] in $loaded} continue lappend loaded $file set content [::practcl::cat [file join $srcdir {*}$file]] AutoDoc scan_text $content puts $fout "###\n# START: [file tail $file]\n###" puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # Provide some cleanup and our final package provide puts $fout [string map $modmap { namespace eval ::%module% { namespace export * } }] close $fout ### # Build our pkgIndex.tcl file ### set fout [open [file join $moddir pkgIndex.tcl] w] puts $fout [string map $modmap {# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} }] puts $fout [string map $modmap { package ifneeded %module% %version% [list source [file join $dir %module%.tcl]] }] close $fout ### # Generate the test script ### namespace eval ::clay {} source [file join $srcdir core.tcl] set fout [open [file join $moddir $filename.test] w] puts $fout [source [file join $srcdir test.tcl]] close $fout set manout [open [file join $moddir $filename.man] w] puts $manout [AutoDoc manpage map $modmap \ header [::practcl::cat [file join $srcdir manual.txt]] \ authors $authors \ footer [::practcl::cat [file join $srcdir footer.txt]] \ ] close $manout |
Added modules/dicttool/build/core.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | namespace eval ::dicttool {} namespace eval ::tcllib {} ### # Because many features in this package may be added as # commands to future tcl cores, or be provided in binary # form by packages, I need a declarative way of saying # [emph {Create this command if there isn't one already}]. # The [emph ninja] argument is a script to execute if the # command is created by this mechanism. ### proc ::tcllib::PROC {name arglist body {ninja {}}} { if {[info commands $name] ne {}} return proc $name $arglist $body eval $ninja } if {[info commands ::PROC] eq {}} { namespace eval ::tcllib { namespace export PROC } namespace eval :: { namespace import ::tcllib::PROC } } ### # Perform a noop. Useful in prototyping for commenting out blocks # of code without actually having to comment them out. It also makes # a handy default for method delegation if a delegate has not been # assigned yet. proc ::tcllib::noop args {} if {[info commands ::noop] eq {}} { namespace eval ::tcllib { namespace export noop } namespace eval :: { namespace import ::tcllib::noop } } ### # Append a line of text to a variable. Optionally apply a string mapping. # arglist: # map {mandatory 0 positional 1} # text {mandatory 1 positional 1} ### proc ::tcllib::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { append buffer [lindex $args 0] \n } 2 { append buffer [string map {*}$args] \n } default { error "usage: putb buffername ?map? string" } } } if {[info command ::putb] eq {}} { namespace eval ::tcllib { namespace export putb } namespace eval :: { namespace import ::tcllib::putb } } |
Added modules/dicttool/build/dict.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 | ### # If the path (given by the list of elements) exists, return that value. # Otherwise return an empty string. Designed to replace [example { # if {[dict exists $dictionary {*}$args]} { # return [dict get $dictionary {*}$args] # } else { # return {} # } # }] # example: # set value [dict getnull $arglist $option] # arglist: # dictionary {mandatory 1 positional 1} # element {mandatory 0 positional 1 repeating 1} ### ::tcllib::PROC ::tcl::dict::getnull {dictionary args} { if {[exists $dictionary {*}$args]} { get $dictionary {*}$args } } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull] } ### # Test if value is a dict. # [para] # This command is added to the [fun dict] ensemble as [fun {dict is_dict}] ### ::tcllib::PROC ::tcl::dict::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict] } ### # A routine to recursively dig through dicts and merge # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/ ### ::tcllib::PROC ::tcl::dict::rmerge {args} { ::set result [dict create . {}] # Merge b into a, and handle nested dicts appropriately ::foreach b $args { for { k v } $b { ::set field [string trim $k :/] if {![::dicttool::is_branch $b $k]} { # Element names that end in ":" are assumed to be literals set result $k $v } elseif { [exists $result $k] } { # key exists in a and b? let's see if both values are dicts # both are dicts, so merge the dicts if { [is_dict [get $result $k]] && [is_dict $v] } { set result $k [rmerge [get $result $k] $v] } else { set result $k $v } } else { set result $k $v } } } return $result } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge] } ### # Return true if the element [variable path] with the value [variable dict] # is a dict. [variable path] is given as a list to descend into sub-dicts of # the current dict. # The rules are as follows: # [list_begin enumerated] # [enum] # If the last character of the last element of [variable path] is a colon (:) # return false # [enum] # If the last character of the last element of [variable path] is a slash (/) # return true # [enum] # If a sub-element if [variable path] named [const .info] is present return true # [list_end] # [para] # [para] # This command is added to the [fun dict] ensemble as [fun {dicttool::is_branch}] # example: # > set mydict {sub/ {sub/ {field {A block of text}}} # > dicttool::is_branch $mydict sub/ # 1 # > dicttool::is_branch $mydict {sub/ sub/} # 1 # > dicttool::is_branch $mydict {sub/ sub/ field} # 0 ### ::tcllib::PROC ::dicttool::is_branch { dict path } { set field [lindex $path end] if {[string index $field end] eq ":"} { return 0 } if {[string index $field 0] eq "."} { return 0 } if {[string index $field end] eq "/"} { return 1 } return [dict exists $dict {*}$path .] } ### # Output a dictionary as an indented stream of # data suitable for output to the screen. The system uses # the rules for [fun {dicttool::is_branch}] to determine if # an value in a dictionary is a leaf or a branch. # example: # > set mydict {sub/ {sub/ {field {A block of text}}} # > dicttool::print $mydict # sub/ { # sub/ { # field {A block of text} # } # } ### ::tcllib::PROC ::dicttool::print {dict} { ::set result {} ::set level -1 ::dicttool::_dictputb $level result $dict return $result } ### # Helper function for ::dicttool::print # Formats the string representation for a dictionary element within # a human readable stream of lines, and determines if it needs to call itself # with further indentation to express a sub-branch ### ::tcllib::PROC ::dicttool::_dictputb {level varname dict} { upvar 1 $varname result incr level dict for {field value} $dict { if {$field eq "."} continue if {[dicttool::is_branch $dict $field]} { putb result "[string repeat " " $level]$field \{" _dictputb $level result $value putb result "[string repeat " " $level]\}" } else { putb result "[string repeat " " $level][list $field $value]" } } } ### # Output a dictionary removing any . entries added by [fun {dicttool::merge}] ### proc ::dicttool::sanitize {dict} { ::set result {} ::set level -1 ::dicttool::_sanitizeb {} result $dict return $result } ### # Helper function for ::dicttool::sanitize # Formats the string representation for a dictionary element within # a human readable stream of lines, and determines if it needs to call itself # with further indentation to express a sub-branch ### proc ::dicttool::_sanitizeb {path varname dict} { upvar 1 $varname result dict for {field value} $dict { if {$field eq "."} continue if {[dicttool::is_branch $dict $field]} { _sanitizeb [list {*}$path $field] result $value } else { dict set result {*}$path $field $value } } } ### # Return the path as a storage path for dicttool # with all branch terminators removed. # This command will also break arguments up if they # contain /. # example: # > dicttool::storage {foo bar baz bang} # foo bar baz bang # > dicttool::storage {foo bar baz bang/} # foo bar baz bang # > dicttool::storage {foo bar baz bang:} # foo bar baz bang: # > dicttool::storage {foo/bar/baz bang:} # foo bar baz bang: # > dicttool::storage {foo/bar/baz/bang} # foo bar baz bang ### proc ::dicttool::storage {rawpath} { set isleafvar 0 set path {} set tail [string index $rawpath end] foreach element $rawpath { set items [split [string trim $element /] /] foreach item $items { if {$item eq {}} continue lappend path $item } } return $path } ### # Set an element with a recursive dictionary, # marking all branches on the way down to the # final element. # If the value does not exists in the nested dictionary # it is added as a leaf. If the value already exists as a branch # the value given is merged if the value is a valid dict. If the # incoming value is not a valid dict, the value overrides the value # stored, and the value is treated as a leaf from then on. # example: # > set r {} # > ::dicttool::dictset r option color default Green # . {} option {. {} color {. {} default Green}} # > ::dicttool::dictset r option {Something not dictlike} # . {} option {Something not dictlike} # # Note that if the value is not a dict, and you try to force it to be # # an error with be thrown on the merge # > ::dicttool::dictset r option color default Blue # missing value to go with key ### proc ::dicttool::dictset {varname args} { upvar 1 $varname result if {[llength $args] < 2} { error "Usage: ?path...? path value" } elseif {[llength $args]==2} { set rawpath [lindex $args 0] } else { set rawpath [lrange $args 0 end-1] } set value [lindex $args end] set path [storage $rawpath] set dot . set one {} dict set result $dot $one set dpath {} foreach item [lrange $path 0 end-1] { set field $item lappend dpath [string trim $item /] dict set result {*}$dpath $dot $one } set field [lindex $rawpath end] set ext [string index $field end] if {$ext eq {:} || ![dict is_dict $value]} { dict set result {*}$path $value return } if {$ext eq {/} && ![dict exists $result {*}$path $dot]} { dict set result {*}$path $dot $one } if {[dict exists $result {*}$path $dot]} { dict set result {*}$path [::dicttool::merge [dict get $result {*}$path] $value] return } dict set result {*}$path $value } ### # A recursive form of dict merge, intended for modifying variables in place. # example: # > set mydict {sub/ {sub/ {description {a block of text}}}} # > ::dicttool::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}] # > dicttool::print $mydict # sub/ { # sub/ { # description {a block of text} # field {another block of text} # } # } ### proc ::dicttool::dictmerge {varname args} { upvar 1 $varname result set dot . set one {} dict set result $dot $one foreach dict $args { dict for {f v} $dict { set field [string trim $f /] set bbranch [dicttool::is_branch $dict $f] if {![dict exists $result $field]} { dict set result $field $v if {$bbranch} { dict set result $field [dicttool::merge $v] } else { dict set result $field $v } } elseif {[dict exists $result $field $dot]} { if {$bbranch} { dict set result $field [dicttool::merge [dict get $result $field] $v] } else { dict set result $field $v } } } } return $result } ### # A recursive form of dict merge # [para] # A routine to recursively dig through dicts and merge # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/ # example: # > set mydict {sub/ {sub/ {description {a block of text}}}} # > set odict [dicttool::merge $mydict {sub/ {sub/ {field {another block of text}}}}] # > dicttool::print $odict # sub/ { # sub/ { # description {a block of text} # field {another block of text} # } # } ### proc ::dicttool::merge {args} { ### # The result of a merge is always a dict with branches ### set dot . set one {} dict set result $dot $one set argument 0 foreach b $args { # Merge b into a, and handle nested dicts appropriately if {![dict is_dict $b]} { error "Element $b is not a dictionary" } dict for { k v } $b { if {$k eq $dot} { dict set result $dot $one continue } set bbranch [is_branch $b $k] set field [string trim $k /] if { ![dict exists $result $field] } { if {$bbranch} { dict set result $field [merge $v] } else { dict set result $field $v } } else { set abranch [dict exists $result $field $dot] if {$abranch && $bbranch} { dict set result $field [merge [dict get $result $field] $v] } else { dict set result $field $v if {$bbranch} { dict set result $field $dot $one } } } } } return $result } ### # Returns true if the path specified by args either does not exist, # if exists and contains an empty string or the value of NULL or null. # [para] # This function is added to the global dict ensemble as [fun {dict isnull}] ### ::tcllib::PROC ::tcl::dict::isnull {dictionary args} { if {![exists $dictionary {*}$args]} {return 1} return [expr {[get $dictionary {*}$args] in {{} NULL null}}] } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull] } |
Added modules/dicttool/build/dictargs.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | namespace eval ::dictargs {} if {[info commands ::dictargs::parse] eq {}} { proc ::dictargs::parse {argdef argdict} { set result {} dict for {field info} $argdef { if {![string is alnum [string index $field 0]]} { error "$field is not a simple variable name" } upvar 1 $field _var set aliases {} if {[dict exists $argdict $field]} { set _var [dict get $argdict $field] continue } if {[dict exists $info aliases:]} { set found 0 foreach {name} [dict get $info aliases:] { if {[dict exists $argdict $name]} { set _var [dict get $argdict $name] set found 1 break } } if {$found} continue } if {[dict exists $info default:]} { set _var [dict get $info default:] \n continue } set mandatory 1 if {[dict exists $info mandatory:]} { set mandatory [dict get $info mandatory:] } if {$mandatory} { error "$field is required" } } } } ### # Named Procedures as new command ### proc ::dictargs::proc {name argspec body} { set result {} append result "::dictargs::parse \{$argspec\} \$args" \; append result $body uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result] } proc ::dictargs::method {name argspec body} { set class [lindex [::info level -1] 1] set result {} append result "::dictargs::parse \{$argspec\} \$args" \; append result $body oo::define $class method $name [list [list args [list dictargs $argspec]]] $result } |
Added modules/dicttool/build/footer.txt.
> > | 1 2 | [vset CATEGORY dict] [include ../doctools2base/include/feedback.inc] |
Added modules/dicttool/build/list.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ### # Add elements to a list if that are not already present in the list. # As a side effect, if variable [variable varname] does not exists, # create it as an empty list. # arglist: # varname {positional 1 mandatory 1} # element {positional 1 mandatory 0 repeating 1} # example: # ladd contents foo bar # puts $contents # > foo bar # ladd contents foo bar baz bang # puts $contents # > foo bar baz bang ### ::tcllib::PROC ::dicttool::ladd {varname args} { upvar 1 $varname var if ![info exists var] { set var {} } foreach item $args { if {$item in $var} continue lappend var $item } return $var } ### # Delete all instances of the elements given from a list contained in [variable varname]. # If the variable does exist this is a noop. # arglist: # varname {positional 1 mandatory 1} # element {positional 1 mandatory 0 repeating 1} # example: # set contents {foo bar baz bang foo foo foo} # ldelete contents foo # puts $contents # > bar baz bang ### ::tcllib::PROC ::dicttool::ldelete {varname args} { upvar 1 $varname var if ![info exists var] { return } foreach item [lsort -unique $args] { while {[set i [lsearch $var $item]]>=0} { set var [lreplace $var $i $i] } } return $var } ### # Return a random element from [variable list] ### ::tcllib::PROC ::dicttool::lrandom list { set len [llength $list] set idx [expr int(rand()*$len)] return [lindex $list $idx] } |
Added modules/dicttool/build/manual.txt.
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | [keywords dict] [copyright {2018 Sean Woods <[email protected]>}] [moddesc {Extensions to the standard "dict" command}] [category Utilities] [titledesc {Dictionary Tools}] [require Tcl 8.5] [description] [para] The [package dicttool] package enhances the standard [emph dict] command with several new commands. In addition, the package also defines several "creature comfort" list commands as well. Each command checks to see if a command already exists of the same name before adding itself, just in case any of these slip into the core. |
Added modules/dicttool/build/test.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 354 355 356 357 358 | set result {} putb result { # dicttool.test - Copyright (c) 2018 Sean Woods # ------------------------------------------------------------------------- source [file join [file dirname [file dirname [file join [pwd] [info script]]]] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { } testing { useLocal dicttool.tcl dicttool }} putb result { ### # Test canonical mapping ### } set test 0 foreach {pattern canonical storage} { {foo bar baz} {foo/ bar/ baz} {foo bar baz} {foo bar baz/} {foo/ bar/ baz/} {foo bar baz} {foo bar .} {foo/ bar} {foo bar .} {foo/ bar/ .} {foo/ bar} {foo bar .} {foo . bar . baz .} {foo/ bar/ baz} {foo . bar . baz .} {foo bar baz bat:} {foo/ bar/ baz/ bat:} {foo bar baz bat:} {foo:} {foo:} {foo:} {foo/bar/baz/bat:} {foo/ bar/ baz/ bat:} {foo bar baz bat:} } { dict set map %pattern% $pattern dict set map %canonical% $canonical dict set map %storage% $storage incr test noop { dict set map %test% [format "test-canonical-%04d" $test] putb result $map { test {%test%} {Test ::dicttool::canonical with %pattern%} { dicttool::canonical {%pattern%} } {%canonical%} } } dict set map %test% [format "test-storage-%04d" $test] putb result $map { test {%test%} {Test ::dicttool::storage with %pattern%} { dicttool::storage {%pattern%} } {%storage%} } } putb result { dict set r foo/ bar/ baz 1 dict set s foo/ bar/ baz 0 set t [dicttool::merge $r $s] test rmerge-0001 {Test that the root is marked as a branch} { dict get $t foo bar baz } 0 set r [dict create] dicttool::dictmerge r { foo/ { bar/ { baz 1 bing: 2 bang { bim 3 boom 4 } womp: {a 1 b 2} } } } test dictmerge-0001 {Test that the root is marked as a branch} { dict exists $r . } 1 test dictmerge-0002 {Test that branch foo is marked correctly} { dict exists $r foo . } 1 test dictmerge-0003 {Test that branch bar is marked correctly} { dict exists $r foo bar . } 1 test dictmerge-0004 {Test that leaf foo/bar/bang is not marked as branch despite being a dict} { dict exists $r foo bar bang . } 0 test dictmerge-0004 {Test that leaf foo/bar/bang/bim exists} { dict exists $r foo bar bang bim } 1 test dictmerge-0005 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 1 ### # Replace bang with bang/ ### dicttool::dictmerge r { foo/ { bar/ { bang/ { whoop 1 } } } } test dictmerge-0006 {Test that leaf foo/bar/bang/bim ceases to exist} { dict exists $r foo bar bang bim } 0 test dictmerge-0007 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 0 test dictmerge-0008 {Test that leaf foo/bar/bang is now a branch} { dict exists $r foo bar bang . } 1 test branch-0001 {Test that foo/ is a branch} { dicttool::is_branch $r foo/ } 1 test branch-0002 {Test that foo is a branch} { dicttool::is_branch $r foo } 1 test branch-0003 {Test that foo/bar/ is a branch} { dicttool::is_branch $r {foo/ bar/} } 1 test branch-0004 {Test that foo bar is not branch} { dicttool::is_branch $r {foo bar} } 1 test branch-0004 {Test that foo/ bar is not branch} { dicttool::is_branch $r {foo/ bar} } 0 } set test 0 foreach {path isbranch} { foo 1 {foo bar} 1 {foo bar baz} 0 {foo bar bing} 0 {foo bar bang} 1 {foo bar bang whoop} 0 } { set mpath [lrange $path 0 end-1] set item [lindex $path end] set tests [list {} {} $isbranch {} : 0 {} / 1 . {} 0] dict set map %mpath% $mpath dict set map %item% $item foreach {head tail isbranch} $tests { dict set map %head% $head dict set map %tail% $tail dict set map %isbranch% $isbranch dict set map %test% [format "test-branch-%04d" [incr test]] putb result $map { test {%test%} {Test that %mpath% %head%%item%%tail% is_branch = %isbranch%} { dicttool::is_branch $r {%mpath% %head%%item%%tail%} } %isbranch% } } } putb result { # ------------------------------------------------------------------------- # dictmerge Testing - oometa unset -nocomplain foo dicttool::dictmerge foo { option/ { color/ { label Color default green } } } dicttool::dictmerge foo { option/ { color/ { default purple } } } test oometa-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color default } purple test oometa-0002 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color label } Color unset -nocomplain foo set foo {. {}} ::dicttool::dictmerge foo {. {} color {. {} default green label Color}} ::dicttool::dictmerge foo {. {} color {. {} default purple}} test oometa-0003 {Recursive merge problem from oometa/clay find} { dict get $foo color default } purple test oometa-0004 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color unset -nocomplain foo set foo {. {}} ::dicttool::dictmerge foo {. {} color {. {} default purple}} ::dicttool::dictmerge foo {. {} color {. {} default green label Color}} test oometa-0005 {Recursive merge problem from oometa/clay find} { dict get $foo color default } green test oometa-0006 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color test oometa-0008 {Un-Sanitized output} { set foo } {. {} color {. {} default green label Color}} test oometa-0009 {Sanitize} { dicttool::sanitize $foo } {color {default green label Color}} } putb result { # ------------------------------------------------------------------------- # dictmerge Testing - clay unset -nocomplain foo test clay-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { ::dicttool::dictmerge foo set foo } {. {}} unset -nocomplain foo ::dicttool::dictset foo bar/ baz/ bell bang test clay-0002 {For new entries dictmerge is essentially a set} { dict get $foo bar baz bell } {bang} ::dicttool::dictset foo bar/ baz/ boom/ bang test clay-0003 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz bell } {bang} test clay-0004 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz boom } {bang} ::dicttool::dictset foo bar/ baz/ bop {color green flavor strawberry} test clay-0005 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color green flavor strawberry} ::dicttool::dictset foo bar/ baz/ bop {color yellow} test clay-0006 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color yellow} ::dicttool::dictset foo bar/ baz/ bang/ {color green flavor strawberry} test clay-0007a {Branches are merged} { dict get $foo bar baz bang } {. {} color green flavor strawberry} ::dicttool::dictset foo bar/ baz/ bang/ color yellow test clay-0007b {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry} ::dicttool::dictset foo bar/ baz/ bang/ {color blue} test clay-0007c {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry} ::dicttool::dictset foo bar/ baz/ bang/ shape: {Sort of round} test clay-0007d {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::dicttool::dictset foo bar/ baz/ bang/ color yellow test clay-0007e {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry shape: {Sort of round}} ::dicttool::dictset foo bar/ baz/ bang/ {color blue} test clay-0007f {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::dicttool::dictset foo dict my_var 10 ::dicttool::dictset foo dict my_other_var 9 test clay-0007g {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9} ::dicttool::dictset foo dict/ my_other_other_var 8 test clay-0007h {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9 my_other_other_var 8} ::dicttool::dictmerge foo {option/ {color {type color} flavor {sense taste}}} ::dicttool::dictmerge foo {option/ {format {default ascii}}} test clay-0008 {Whole dicts are merged} { dict get $foo option color } {type color} test clay-0009 {Whole dicts are merged} { dict get $foo option flavor } {sense taste} test clay-0010 {Whole dicts are merged} { dict get $foo option format } {default ascii} ### # Tests for the httpd module ### test clay-0010 {Test that leaves are merged properly} set bar {} ::dicttool::dictmerge bar { proxy/ {port 10101 host myhost.localhost} } ::dicttool::dictmerge bar { mimetxt {Host: localhost Content_Type: text/plain Content-Length: 15 } http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}} mixin {reply ::test::content.echo} prefix /echo proxy_port 10010 proxy/ {host localhost} } test clay-0011 {Whole dicts are merged} { dict get $bar proxy_port } {10010} test clay-0012 {Whole dicts are merged} { dict get $bar http CONTENT_LENGTH } 15 test clay-0013 {Whole dicts are merged} { dict get $bar proxy host } localhost test clay-0014 {Whole dicts are merged} { dict get $bar proxy port } 10101 } putb result { testsuiteCleanup # Local variables: # mode: tcl # indent-tabs-mode: nil # End: } return $result |
Deleted modules/dicttool/dicttool.man.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/dicttool/dicttool.md.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/dicttool/dicttool.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/dicttool/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. | > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded dicttool 1.2 [list source [file join $dir dicttool.tcl]] |
Changes to modules/dns/dns.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testing { useLocal dns.tcl dns } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/dns/ip.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal ip.tcl ip } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/dns/ipMore.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.2 testing { useLocal ip.tcl ip } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/dns/spf.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useLocal dns.tcl dns; # tcllib 1.3 useLocal ip.tcl ip; # tcllib 1.7 use log/logger.tcl logger; # tcllib 1.3 use struct/list.tcl struct::list; # tcllib 1.7 |
︙ | ︙ |
Changes to modules/docstrip/docstrip.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | ## * This Source is not the True Source * ## ************************************** ## the true source is the file from which this one was generated. ## source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ## * This Source is not the True Source * ## ************************************** ## the true source is the file from which this one was generated. ## source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 testing {useLocal docstrip.tcl docstrip} variable docstrip_sources_dir [localPath {}] tcltest::testConstraint docstripSourcesAvailable [expr {[ file exists [file join $docstrip_sources_dir docstrip.tcl] ] && [ file exists [file join $docstrip_sources_dir tcldocstrip.dtx] |
︙ | ︙ |
Changes to modules/docstrip/docstrip_util.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | ## * This Source is not the True Source * ## ************************************** ## the true source is the file from which this one was generated. ## source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ## * This Source is not the True Source * ## ************************************** ## the true source is the file from which this one was generated. ## source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 testing {useLocal docstrip.tcl docstrip} testing {useLocal docstrip_util.tcl docstrip::util} variable docstrip_sources_dir [localPath {}] tcltest::testConstraint docstripSourcesAvailable [expr {[ file exists [file join $docstrip_sources_dir docstrip.tcl] ] && [ |
︙ | ︙ |
Changes to modules/docstrip/tcldocstrip.dtx.
︙ | ︙ | |||
578 579 580 581 582 583 584 | % \changes{1.2.1}{2006/09/13}{Modified the setup of the testsuite % to match the other modules and packages in \Tcllib. (AK)} % \begin{tcl} %<*tcllibtest> source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] | | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 | % \changes{1.2.1}{2006/09/13}{Modified the setup of the testsuite % to match the other modules and packages in \Tcllib. (AK)} % \begin{tcl} %<*tcllibtest> source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 testing {useLocal docstrip.tcl docstrip} %<utiltest>testing {useLocal docstrip_util.tcl docstrip::util} variable docstrip_sources_dir [localPath {}] %</tcllibtest> % \end{tcl} % One of the tests require that \texttt{tcldocstrip.dtx} (this file) and |
︙ | ︙ |
Changes to modules/doctools/docidx.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use textutil/expander.tcl textutil::expander use fileutil/fileutil.tcl fileutil } testing { |
︙ | ︙ |
Changes to modules/doctools/doctoc.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use textutil/expander.tcl textutil::expander use fileutil/fileutil.tcl fileutil } testing { |
︙ | ︙ |
Changes to modules/doctools/doctools.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use textutil/expander.tcl textutil::expander use fileutil/fileutil.tcl fileutil } testing { |
︙ | ︙ |
Changes to modules/doctools2base/msgcat.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { # NOTE: Better use a base local file and test package ? use doctools2idx/msgcat_c.tcl doctools::msgcat::idx::c ; # See 'doctools-msgcat-2.0'. } testing { |
︙ | ︙ |
Changes to modules/doctools2base/tcl_parse.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree useAccel [useTcllibC] struct/stack.tcl struct::stack |
︙ | ︙ |
Changes to modules/doctools2idx/container.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # idx.test: Tests for the doctools::idx package. Index management. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # idx.test: Tests for the doctools::idx package. Index management. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { use struct/list.tcl struct::list use snit/snit.tcl snit use fileutil/fileutil.tcl fileutil use fileutil/paths.tcl fileutil::paths |
︙ | ︙ |
Changes to modules/doctools2idx/export.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # idx.test: tests for the doctools::idx package. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]] ]] devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # idx.test: tests for the doctools::idx package. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]] ]] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { use fileutil/fileutil.tcl fileutil ;# tests/common use struct/list.tcl struct::list use snit/snit.tcl snit |
︙ | ︙ |
Changes to modules/doctools2idx/export_docidx.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::idx::structure } testing { |
︙ | ︙ |
Changes to modules/doctools2idx/export_html.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::idx::structure use doctools2base/text.tcl doctools::text use doctools2base/html.tcl doctools::html |
︙ | ︙ |
Changes to modules/doctools2idx/export_json.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common use textutil/adjust.tcl textutil::adjust useLocal structure.tcl doctools::idx::structure } |
︙ | ︙ |
Changes to modules/doctools2idx/export_nroff.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::idx::structure use doctools2base/text.tcl doctools::text use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros |
︙ | ︙ |
Changes to modules/doctools2idx/export_text.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::idx::structure use doctools2base/text.tcl doctools::text } |
︙ | ︙ |
Changes to modules/doctools2idx/export_wiki.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::idx::structure use doctools2base/text.tcl doctools::text } |
︙ | ︙ |
Changes to modules/doctools2idx/import.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # -- idx_import.test: # -- Tests for package "doctools::idx::import": Management of import plugins. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # -- idx_import.test: # -- Tests for package "doctools::idx::import": Management of import plugins. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { use struct/list.tcl struct::list use snit/snit.tcl snit use fileutil/fileutil.tcl fileutil use fileutil/paths.tcl fileutil::paths |
︙ | ︙ |
Changes to modules/doctools2idx/import_docidx.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree useAccel [useTcllibC] struct/stack.tcl struct::stack |
︙ | ︙ |
Changes to modules/doctools2idx/import_json.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil use struct/list.tcl struct::list # Copy of code from idx_import_json.tcl, to define dict support |
︙ | ︙ |
Changes to modules/doctools2idx/parse.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree useAccel [useTcllibC] struct/stack.tcl struct::stack |
︙ | ︙ |
Changes to modules/doctools2idx/structure.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ; # For tests/common use snit/snit.tcl snit } testing { |
︙ | ︙ |
Changes to modules/doctools2toc/container.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # toc.test: Tests for the doctools::toc package. ToC management. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # toc.test: Tests for the doctools::toc package. ToC management. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree use struct/list.tcl struct::list |
︙ | ︙ |
Changes to modules/doctools2toc/export.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # toc.test: tests for the doctools::toc package. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # toc.test: tests for the doctools::toc package. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { use fileutil/fileutil.tcl fileutil ;# tests/common use struct/list.tcl struct::list use snit/snit.tcl snit |
︙ | ︙ |
Changes to modules/doctools2toc/export_doctoc.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::toc::structure } testing { |
︙ | ︙ |
Changes to modules/doctools2toc/export_html.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::toc::structure use doctools2base/text.tcl doctools::text use doctools2base/html.tcl doctools::html |
︙ | ︙ |
Changes to modules/doctools2toc/export_json.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common use textutil/adjust.tcl textutil::adjust useLocal structure.tcl doctools::toc::structure } |
︙ | ︙ |
Changes to modules/doctools2toc/export_nroff.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::toc::structure use doctools2base/text.tcl doctools::text use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros |
︙ | ︙ |
Changes to modules/doctools2toc/export_text.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::toc::structure use doctools2base/text.tcl doctools::text } |
︙ | ︙ |
Changes to modules/doctools2toc/export_wiki.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ;# tests/common useLocal structure.tcl doctools::toc::structure use doctools2base/text.tcl doctools::text } |
︙ | ︙ |
Changes to modules/doctools2toc/import.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # -- toc_import.test: # -- Tests for package "doctools::toc::import": Management of import plugins. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # -- toc_import.test: # -- Tests for package "doctools::toc::import": Management of import plugins. # # Copyright (c) 2009-2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { use struct/list.tcl struct::list use snit/snit.tcl snit use fileutil/fileutil.tcl fileutil use fileutil/paths.tcl fileutil::paths |
︙ | ︙ |
Changes to modules/doctools2toc/import_doctoc.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree useAccel [useTcllibC] struct/stack.tcl struct::stack |
︙ | ︙ |
Changes to modules/doctools2toc/import_json.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil use struct/list.tcl struct::list # Copy of code from import_json.tcl, to define dict support |
︙ | ︙ |
Changes to modules/doctools2toc/parse.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree useAccel [useTcllibC] struct/stack.tcl struct::stack |
︙ | ︙ |
Changes to modules/doctools2toc/structure.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use fileutil/fileutil.tcl fileutil ; # For tests/common use snit/snit.tcl snit } testing { |
︙ | ︙ |
Changes to modules/exif/exif.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal exif.tcl exif } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/fileutil/find.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useLocalFile find.setup } testing { useLocal fileutil.tcl fileutil |
︙ | ︙ |
Changes to modules/fileutil/inplace.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal fileutil.tcl fileutil } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/fileutil/multi.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use snit/snit.tcl snit use struct/list.tcl struct::list use wip/wip.tcl wip useLocal fileutil.tcl fileutil |
︙ | ︙ |
Changes to modules/fileutil/multiop.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use snit/snit.tcl snit use struct/list.tcl struct::list # Note: Order is important for the next two. First ::fileutil is |
︙ | ︙ |
Changes to modules/fileutil/pathops.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal fileutil.tcl fileutil } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/fileutil/strip.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal fileutil.tcl fileutil } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/fileutil/test.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal fileutil.tcl fileutil } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/fileutil/traverse.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use control/control.tcl control use snit/snit.tcl snit useLocalFile find.setup |
︙ | ︙ |
Changes to modules/grammar_fa/dacceptor.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # daccept.test: tests for the grammar::fa::dacceptor - DFA acceptor class # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: dacceptor.test,v 1.10 2007/04/12 03:43:14 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # daccept.test: tests for the grammar::fa::dacceptor - DFA acceptor class # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: dacceptor.test,v 1.10 2007/04/12 03:43:14 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite. |
︙ | ︙ |
Changes to modules/grammar_fa/dexec.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # dexec.test: tests for the grammar::fa::dexec - DFA executor class # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: dexec.test,v 1.10 2007/04/12 03:43:14 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # dexec.test: tests for the grammar::fa::dexec - DFA executor class # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: dexec.test,v 1.10 2007/04/12 03:43:14 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite. |
︙ | ︙ |
Changes to modules/grammar_fa/fa.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # fa.test: tests for the grammar::fa container. # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: fa.test,v 1.12 2009/10/27 21:17:23 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # fa.test: tests for the grammar::fa container. # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: fa.test,v 1.12 2009/10/27 21:17:23 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 snitErrors support { useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set |
︙ | ︙ |
Changes to modules/grammar_fa/faop.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # faop.test: tests for complex operations on the grammar::fa container. # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: faop.test,v 1.11 2007/04/12 03:43:14 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # faop.test: tests for complex operations on the grammar::fa container. # # Copyright (c) 2004-2007 by Andreas Kupries <[email protected]> # # RCS: @(#) $Id: faop.test,v 1.11 2007/04/12 03:43:14 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite. |
︙ | ︙ |
Changes to modules/grammar_me/me_cpu.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use fileutil/fileutil.tcl fileutil useLocal me_cpucore.tcl grammar::me::cpu::core } testing { |
︙ | ︙ |
Changes to modules/grammar_me/me_cpucore.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use fileutil/fileutil.tcl fileutil } testing { useLocal me_cpucore.tcl grammar::me::cpu::core |
︙ | ︙ |
Changes to modules/grammar_me/me_tcl.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 testing { useLocal me_tcl.tcl grammar::me::tcl } # ### ### ### ######### ######### ######### |
︙ | ︙ |
Changes to modules/grammar_me/me_util.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree } testing { |
︙ | ︙ |
Changes to modules/hook/hook.test.
︙ | ︙ | |||
497 498 499 500 501 502 503 | } -cleanup { cleanup } -result {{S1 <H1> {} {O1 O2}} {S2 <H2> {} O2} {S3 <H3> {} {}}} #----------------------------------------------------------------------- # Clean up and finish | | < | 497 498 499 500 501 502 503 504 | } -cleanup { cleanup } -result {{S1 <H1> {} {O1 O2}} {S2 <H2> {} O2} {S3 <H3> {} {}}} #----------------------------------------------------------------------- # Clean up and finish ::tcltest::cleanupTestsreturn |
Changes to modules/html/html.tcl.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla package require Tcl 8.2 | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla package require Tcl 8.2 package require ncgi 1.4 package provide html 1.5 namespace eval ::html { # State about the current page variable page |
︙ | ︙ |
Changes to modules/html/html.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | > > > > > | 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 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { use ncgi/ncgi.tcl ncgi } support { use md5/md5x.tcl md5 use mime/mime-1.6.tcl mime use ncgi/ncgi-1.4.tcl ncgi } testing { useLocal html.tcl html } # ------------------------------------------------------------------------- test html-1.1 {html::init} -body { |
︙ | ︙ | |||
586 587 588 589 590 591 592 | test html-27.8 {html::foreach--subst body w/ nested foreach} { html::foreach x {a b} { [html::foreach y {c d} {$x$y}] } } { acad | | | | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 | test html-27.8 {html::foreach--subst body w/ nested foreach} { html::foreach x {a b} { [html::foreach y {c d} {$x$y}] } } { acad bcbd } test html-27.9 {html::foreach--subst body w/ multiple nested foreach's} { html::foreach x {a b} { [html::foreach y {c d} {$x$y [html::foreach z {e f} {$z}] }]} } { ac ef ad ef bc ef bd ef } test html-28.1 {html::for--1 iteration} { |
︙ | ︙ |
Changes to modules/htmlparse/htmlparse.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 ; # htmlparse itself is 8.2+, however struct::* need 8.3+ testsNeedTcltest 1.0 support { use struct/list.tcl struct::list useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree |
︙ | ︙ |
Changes to modules/httpd/build/build.tcl.
︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 64 65 66 67 | puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # These files can be loaded in any order foreach file [glob [file join $srcdir *.tcl]] { if {[file tail $file] in $loaded} continue lappend loaded $file set fin [open [file join $srcdir $file] r] puts $fout "###\n# START: [file tail $file]\n###" set content [::practcl::cat [file join $srcdir $file]] AutoDoc scan_text $content puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } | > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # These files can be loaded in any order foreach file [glob [file join $srcdir *.tcl]] { if {[file tail $file] in $loaded} continue lappend loaded $file puts "EXTRA $file" set fin [open [file join $srcdir $file] r] puts $fout "###\n# START: [file tail $file]\n###" set content [::practcl::cat [file join $srcdir $file]] AutoDoc scan_text $content puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } |
︙ | ︙ |
Deleted modules/httpd/build/content.man.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/httpd/build/footer.txt.
1 2 3 4 | [section AUTHORS] Sean Woods [vset CATEGORY network] | | | 1 2 3 4 5 | [section AUTHORS] Sean Woods [vset CATEGORY network] [include ../doctools2base/include/feedback.inc] |
Deleted modules/httpd/build/reply.man.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/httpd/build/reply.tcl.
︙ | ︙ | |||
243 244 245 246 247 248 249 250 251 252 253 254 255 256 | my error 500 $err [dict get $errdat -errorinfo] my DoOutput } finally { my close my clay refcount_decr } } method Dispatch {} { # Invoke the URL implementation. my content my DoOutput } | > > > > > > | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | my error 500 $err [dict get $errdat -errorinfo] my DoOutput } finally { my close my clay refcount_decr } } method Dispatch {} { # Invoke the URL implementation. my content my DoOutput } method Dispatch {} { # Invoke the URL implementation. my content my DoOutput } |
︙ | ︙ |
Deleted modules/httpd/build/server.man.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/httpd/httpd.man.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/httpd/httpd.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/httpd/httpd.test.
︙ | ︙ | |||
584 585 586 587 588 589 590 591 592 593 594 595 596 597 | TESTSCGI uri add * /error [list mixin {reply ::test::content.error}] TESTSCGI uri add * /string [list mixin {reply ::test::content.string} hardcoded_string cherry] ::DEBUG puts scgi-client-0001 test scgi-client-0001 {Do an echo request} -body { ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS IS MY CODE} } -match glob -result [200+status-head {THIS IS MY CODE}] ::DEBUG puts scgi-client-0002 test scgi-client-0002 {Do another echo request} -body { ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT} } -match glob -result [200+status-head {THOUGH THERE ARE MANY LIKE IT}] ::DEBUG puts scgi-client-0003 | > | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 | TESTSCGI uri add * /error [list mixin {reply ::test::content.error}] TESTSCGI uri add * /string [list mixin {reply ::test::content.string} hardcoded_string cherry] ::DEBUG puts scgi-client-0001 test scgi-client-0001 {Do an echo request} -body { ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS IS MY CODE} } -match glob -result [200+status-head {THIS IS MY CODE}] ::DEBUG puts scgi-client-0002 test scgi-client-0002 {Do another echo request} -body { ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT} } -match glob -result [200+status-head {THOUGH THERE ARE MANY LIKE IT}] ::DEBUG puts scgi-client-0003 |
︙ | ︙ |
Changes to modules/ident/ident.test.
1 2 3 4 5 6 7 8 9 10 11 | # ident.test -- -*- tcl -*- # # Tests for the ident package # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # ident.test -- -*- tcl -*- # # Tests for the ident package # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal ident.tcl ident } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/inifile/inifile.test.
1 2 3 4 5 6 7 8 9 | # -*- tcl -*- # Tests for module 'inifile' # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # -*- tcl -*- # Tests for module 'inifile' # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal ini.tcl inifile } #--------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/interp/deleg_method.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # interp.test: tests for the interp alias and creation utilities # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # interp.test: tests for the interp alias and creation utilities # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit testsNeed snit 1.3.1 ; # method introspection arguments/body } testing { |
︙ | ︙ |
Changes to modules/interp/deleg_proc.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # interp.test: tests for the interp alias and creation utilities # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # interp.test: tests for the interp alias and creation utilities # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal deleg_proc.tcl interp::delegate::proc } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/interp/interp.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # interp.test: tests for the interp alias and creation utilities # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # interp.test: tests for the interp alias and creation utilities # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit } testing { useLocal interp.tcl interp |
︙ | ︙ |
Changes to modules/javascript/javascript.tcl.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: javascript.tcl,v 1.5 2005/09/30 05:36:39 andreas_kupries Exp $ package require Tcl 8 | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: javascript.tcl,v 1.5 2005/09/30 05:36:39 andreas_kupries Exp $ package require Tcl 8 package require ncgi 1.4 package provide javascript 1.0.2 namespace eval ::javascript { # The SelectionObjList namespace variable is used to keep the list of # selection boxes that were created as parts of paired multi-selection |
︙ | ︙ | |||
292 293 294 295 296 297 298 | # Empty the selection box for the next page. set SelectionObjList {} # Create the HTML submit button. | | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | # Empty the selection box for the next page. set SelectionObjList {} # Create the HTML submit button. append html "<input type=submit name=\"$name\" value=\"$value\" onClick=\"getSelections(this.form)\">" return $html } # ::javascript::makeProtectedSubmitButton -- # |
︙ | ︙ | |||
329 330 331 332 333 334 335 | append html " return false\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML submit button. | | | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 | append html " return false\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML submit button. append html "<input type=submit name=\"$name\" value=\"$value\" onClick=\"return areYouSure${name}(this.form)\">" return $html } # ::javascript::makeMasterButton -- # |
︙ | ︙ | |||
366 367 368 369 370 371 372 | append html " if (form.elements\[i\].name.match('$slavePattern')) \{\n" append html " form.elements\[i\].checked = $boolean \n" append html " \}\n" append html " \}\n" append html "\}\n" append html [EndJS] | | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 | append html " if (form.elements\[i\].name.match('$slavePattern')) \{\n" append html " form.elements\[i\].checked = $boolean \n" append html " \}\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML button object. append html "<input type=button name=\"$master\" value=\"$value\" " \ "onClick=\"checkMaster${master}(this.form)\">\n" return $html } |
︙ | ︙ |
Changes to modules/jpeg/jpeg.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # jpeg.test: Tests for the JPEG utilities. # # Copyright (c) 2008-2013 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # jpeg.test: Tests for the JPEG utilities. # # Copyright (c) 2008-2013 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { use fileutil/fileutil.tcl fileutil } testing { useLocal jpeg.tcl jpeg |
︙ | ︙ |
Changes to modules/json/json.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # json.test - Copyright (C) 2006 ActiveState Software Inc. # # Tests for the Tcllib json package # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # json.test - Copyright (C) 2006 ActiveState Software Inc. # # Tests for the Tcllib json package # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useLocalFile tests/support.tcl } testing { |
︙ | ︙ |
Changes to modules/ldap/ldapx.tcl.
︙ | ︙ | |||
950 951 952 953 954 955 956 | set bind 1 if {[Check $selfns {::ldap::bind $channel $binddn $bindpw}]} then { return 0 } } return 1 } | | | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 | set bind 1 if {[Check $selfns {::ldap::bind $channel $binddn $bindpw}]} then { return 0 } } return 1 } # Disconnect from the LDAP directory method disconnect {} { Connected $selfns if {$bind} { |
︙ | ︙ |
Changes to modules/log/log.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal log.tcl log } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/log/logger.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal logger.tcl logger } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/log/loggerUtils.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.2 support { useLocal logger.tcl logger useLocal loggerAppender.tcl logger::appender } testing { |
︙ | ︙ |
Changes to modules/log/logger_trace.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testing { useLocal logger.tcl logger } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/map/map_slippy.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | package require tcltest source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | package require tcltest source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use snit/snit.tcl snit use math/math.tcl math use math/constants.tcl math::constants } |
︙ | ︙ |
Changes to modules/math/primes.test.
︙ | ︙ |
Changes to modules/md4/md4.test.
1 2 3 4 5 6 7 8 9 10 | # md4.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: md4.test,v 1.15 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # md4.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: md4.test,v 1.15 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal md4.tcl md4 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/md5/md5.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal md5.tcl md5 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/md5/md5x.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal md5x.tcl md5 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/md5crypt/md5crypt.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal md5crypt.tcl md5crypt } # ------------------------------------------------------------------------- |
︙ | ︙ |
Added modules/mime/mime-1.6.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 | # mime.tcl - MIME body parts # # (c) 1999-2000 Marshall T. Rose # (c) 2000 Brent Welch # (c) 2000 Sandeep Tamhankar # (c) 2000 Dan Kuchler # (c) 2000-2001 Eric Melski # (c) 2001 Jeff Hobbs # (c) 2001-2008 Andreas Kupries # (c) 2002-2003 David Welton # (c) 2003-2008 Pat Thoyts # (c) 2005 Benjamin Riefenstahl # (c) 2013 PoorYorick # # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's # unpublished package of 1999. # # new string features and inline scan are used, requiring 8.3. package require Tcl 8.5 package provide mime 1.6 if {[catch {package require Trf 2.0}]} { # Fall-back to tcl-based procedures of base64 and quoted-printable encoders # Warning! # These are a fragile emulations of the more general calling sequence # that appears to work with this code here. package require base64 2.0 set ::major [lindex [split [package require md5] .] 0] # Create these commands in the mime namespace so that they # won't collide with things at the global namespace level namespace eval ::mime { proc base64 {-mode what -- chunk} { return [base64::$what $chunk] } proc quoted-printable {-mode what -- chunk} { return [mime::qp_$what $chunk] } if {$::major < 2} { # md5 v1, result is hex string ready for use. proc md5 {-- string} { return [md5::md5 $string] } } else { # md5 v2, need option to get hex string proc md5 {-- string} { return [md5::md5 -hex $string] } } } unset ::major } # # state variables: # # canonicalP: input is in its canonical form # content: type/subtype # params: seralized array of key/value pairs (keys are lower-case) # encoding: transfer encoding # version: MIME-version # header: serialized array of key/value pairs (keys are lower-case) # lowerL: list of header keys, lower-case # mixedL: list of header keys, mixed-case # value: either "file", "parts", or "string" # # file: input file # fd: cached file-descriptor, typically for root # root: token for top-level part, for (distant) subordinates # offset: number of octets from beginning of file/string # count: length in octets of (encoded) content # # parts: list of bodies (tokens) # # string: input string # # cid: last child-id assigned # namespace eval ::mime { variable mime array set mime {uid 0 cid 0} # RFC 822 lexemes variable addrtokenL lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\ variable addrlexemeL { LX_SEMICOLON LX_COMMA LX_LBRACKET LX_RBRACKET LX_COLON LX_DOT LX_LPAREN LX_RPAREN LX_ATSIGN LX_QUOTE LX_LSQUARE LX_RSQUARE LX_QUOTE } # RFC 2045 lexemes variable typetokenL lappend typetokenL \; , < > : ? ( ) @ \" \[ \] = / \\ variable typelexemeL { LX_SEMICOLON LX_COMMA LX_LBRACKET LX_RBRACKET LX_COLON LX_QUESTION LX_LPAREN LX_RPAREN LX_ATSIGN LX_QUOTE LX_LSQUARE LX_RSQUARE LX_EQUALS LX_SOLIDUS LX_QUOTE } variable encList { ascii US-ASCII big5 Big5 cp1250 Windows-1250 cp1251 Windows-1251 cp1252 Windows-1252 cp1253 Windows-1253 cp1254 Windows-1254 cp1255 Windows-1255 cp1256 Windows-1256 cp1257 Windows-1257 cp1258 Windows-1258 cp437 IBM437 cp737 {} cp775 IBM775 cp850 IBM850 cp852 IBM852 cp855 IBM855 cp857 IBM857 cp860 IBM860 cp861 IBM861 cp862 IBM862 cp863 IBM863 cp864 IBM864 cp865 IBM865 cp866 IBM866 cp869 IBM869 cp874 {} cp932 {} cp936 GBK cp949 {} cp950 {} dingbats {} ebcdic {} euc-cn EUC-CN euc-jp EUC-JP euc-kr EUC-KR gb12345 GB12345 gb1988 GB1988 gb2312 GB2312 iso2022 ISO-2022 iso2022-jp ISO-2022-JP iso2022-kr ISO-2022-KR iso8859-1 ISO-8859-1 iso8859-2 ISO-8859-2 iso8859-3 ISO-8859-3 iso8859-4 ISO-8859-4 iso8859-5 ISO-8859-5 iso8859-6 ISO-8859-6 iso8859-7 ISO-8859-7 iso8859-8 ISO-8859-8 iso8859-9 ISO-8859-9 iso8859-10 ISO-8859-10 iso8859-13 ISO-8859-13 iso8859-14 ISO-8859-14 iso8859-15 ISO-8859-15 iso8859-16 ISO-8859-16 jis0201 JIS_X0201 jis0208 JIS_C6226-1983 jis0212 JIS_X0212-1990 koi8-r KOI8-R koi8-u KOI8-U ksc5601 KS_C_5601-1987 macCentEuro {} macCroatian {} macCyrillic {} macDingbats {} macGreek {} macIceland {} macJapan {} macRoman {} macRomania {} macThai {} macTurkish {} macUkraine {} shiftjis Shift_JIS symbol {} tis-620 TIS-620 unicode {} utf-8 UTF-8 } variable encodings array set encodings $encList variable reversemap # Initialized at the bottom of the file variable encAliasList { ascii ANSI_X3.4-1968 ascii iso-ir-6 ascii ANSI_X3.4-1986 ascii ISO_646.irv:1991 ascii ASCII ascii ISO646-US ascii us ascii IBM367 ascii cp367 cp437 cp437 cp437 437 cp775 cp775 cp850 cp850 cp850 850 cp852 cp852 cp852 852 cp855 cp855 cp855 855 cp857 cp857 cp857 857 cp860 cp860 cp860 860 cp861 cp861 cp861 861 cp861 cp-is cp862 cp862 cp862 862 cp863 cp863 cp863 863 cp864 cp864 cp865 cp865 cp865 865 cp866 cp866 cp866 866 cp869 cp869 cp869 869 cp869 cp-gr cp936 CP936 cp936 MS936 cp936 Windows-936 iso8859-1 ISO_8859-1:1987 iso8859-1 iso-ir-100 iso8859-1 ISO_8859-1 iso8859-1 latin1 iso8859-1 l1 iso8859-1 IBM819 iso8859-1 CP819 iso8859-2 ISO_8859-2:1987 iso8859-2 iso-ir-101 iso8859-2 ISO_8859-2 iso8859-2 latin2 iso8859-2 l2 iso8859-3 ISO_8859-3:1988 iso8859-3 iso-ir-109 iso8859-3 ISO_8859-3 iso8859-3 latin3 iso8859-3 l3 iso8859-4 ISO_8859-4:1988 iso8859-4 iso-ir-110 iso8859-4 ISO_8859-4 iso8859-4 latin4 iso8859-4 l4 iso8859-5 ISO_8859-5:1988 iso8859-5 iso-ir-144 iso8859-5 ISO_8859-5 iso8859-5 cyrillic iso8859-6 ISO_8859-6:1987 iso8859-6 iso-ir-127 iso8859-6 ISO_8859-6 iso8859-6 ECMA-114 iso8859-6 ASMO-708 iso8859-6 arabic iso8859-7 ISO_8859-7:1987 iso8859-7 iso-ir-126 iso8859-7 ISO_8859-7 iso8859-7 ELOT_928 iso8859-7 ECMA-118 iso8859-7 greek iso8859-7 greek8 iso8859-8 ISO_8859-8:1988 iso8859-8 iso-ir-138 iso8859-8 ISO_8859-8 iso8859-8 hebrew iso8859-9 ISO_8859-9:1989 iso8859-9 iso-ir-148 iso8859-9 ISO_8859-9 iso8859-9 latin5 iso8859-9 l5 iso8859-10 iso-ir-157 iso8859-10 l6 iso8859-10 ISO_8859-10:1992 iso8859-10 latin6 iso8859-14 iso-ir-199 iso8859-14 ISO_8859-14:1998 iso8859-14 ISO_8859-14 iso8859-14 latin8 iso8859-14 iso-celtic iso8859-14 l8 iso8859-15 ISO_8859-15 iso8859-15 Latin-9 iso8859-16 iso-ir-226 iso8859-16 ISO_8859-16:2001 iso8859-16 ISO_8859-16 iso8859-16 latin10 iso8859-16 l10 jis0201 X0201 jis0208 iso-ir-87 jis0208 x0208 jis0208 JIS_X0208-1983 jis0212 x0212 jis0212 iso-ir-159 ksc5601 iso-ir-149 ksc5601 KS_C_5601-1989 ksc5601 KSC5601 ksc5601 korean shiftjis MS_Kanji utf-8 UTF8 } namespace export initialize finalize getproperty \ getheader setheader \ getbody \ copymessage \ mapencoding \ reversemapencoding \ parseaddress \ parsedatetime \ uniqueID } # ::mime::initialize -- # # Creates a MIME part, and returnes the MIME token for that part. # # Arguments: # args Args can be any one of the following: # ?-canonical type/subtype # ?-param {key value}?... # ?-encoding value? # ?-header {key value}?... ? # (-file name | -string value | -parts {token1 ... tokenN}) # # If the -canonical option is present, then the body is in # canonical (raw) form and is found by consulting either the -file, # -string, or -parts option. # # In addition, both the -param and -header options may occur zero # or more times to specify "Content-Type" parameters (e.g., # "charset") and header keyword/values (e.g., # "Content-Disposition"), respectively. # # Also, -encoding, if present, specifies the # "Content-Transfer-Encoding" when copying the body. # # If the -canonical option is not present, then the MIME part # contained in either the -file or the -string option is parsed, # dynamically generating subordinates as appropriate. # # Results: # An initialized mime token. proc ::mime::initialize args { global errorCode errorInfo variable mime set token [namespace current]::[incr mime(uid)] # FRINK: nocheck variable $token upvar 0 $token state if {[catch {{*}[list mime::initializeaux $token {*}$args]} result eopts]} { catch {mime::finalize $token -subordinates dynamic} return -options $eopts $result } return $token } # ::mime::initializeaux -- # # Configures the MIME token created in mime::initialize based on # the arguments that mime::initialize supports. # # Arguments: # token The MIME token to configure. # args Args can be any one of the following: # ?-canonical type/subtype # ?-param {key value}?... # ?-encoding value? # ?-header {key value}?... ? # (-file name | -string value | -parts {token1 ... tokenN}) # # Results: # Either configures the mime token, or throws an error. proc ::mime::initializeaux {token args} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state array set params [set state(params) {}] set state(encoding) {} set state(version) 1.0 set state(header) {} set state(lowerL) {} set state(mixedL) {} set state(cid) 0 set argc [llength $args] for {set argx 0} {$argx < $argc} {incr argx} { set option [lindex $args $argx] if {[incr argx] >= $argc} { error "missing argument to $option" } set value [lindex $args $argx] switch -- $option { -canonical { set state(content) [string tolower $value] } -param { if {[llength $value] != 2} { error "-param expects a key and a value, not $value" } set lower [string tolower [set mixed [lindex $value 0]]] if {[info exists params($lower)]} { error "the $mixed parameter may be specified at most once" } set params($lower) [lindex $value 1] set state(params) [array get params] } -encoding { switch -- [set state(encoding) [string tolower $value]] { 7bit - 8bit - binary - quoted-printable - base64 { } default { error "unknown value for -encoding $state(encoding)" } } } -header { if {[llength $value] != 2} { error "-header expects a key and a value, not $value" } set lower [string tolower [set mixed [lindex $value 0]]] if {$lower eq "content-type"} { error "use -canonical instead of -header $value" } if {$lower eq "content-transfer-encoding"} { error "use -encoding instead of -header $value" } if {$lower in {content-md5 mime-version}} { error "don't go there..." } if {$lower ni $state(lowerL)} { lappend state(lowerL) $lower lappend state(mixedL) $mixed } array set header $state(header) lappend header($lower) [lindex $value 1] set state(header) [array get header] } -file { set state(file) $value } -parts { set state(parts) $value } -string { set state(string) $value set state(lines) [split $value \n] set state(lines.count) [llength $state(lines)] set state(lines.current) 0 } -root { # the following are internal options set state(root) $value } -offset { set state(offset) $value } -count { set state(count) $value } -lineslist { set state(lines) $value set state(lines.count) [llength $state(lines)] set state(lines.current) 0 #state(string) is needed, but will be built when required set state(string) {} } default { error "unknown option $option" } } } #We only want one of -file, -parts or -string: set valueN 0 foreach value {file parts string} { if {[info exists state($value)]} { set state(value) $value incr valueN } } if {$valueN != 1 && ![info exists state(lines)]} { error "specify exactly one of -file, -parts, or -string" } if {[set state(canonicalP) [info exists state(content)]]} { switch -- $state(value) { file { set state(offset) 0 } parts { switch -glob -- $state(content) { text/* - image/* - audio/* - video/* { error "-canonical $state(content) and -parts do not mix" } default { if {$state(encoding) ne {}} { error "-encoding and -parts do not mix" } } } } default {# Go ahead} } if {[lsearch -exact $state(lowerL) content-id] < 0} { lappend state(lowerL) content-id lappend state(mixedL) Content-ID array set header $state(header) lappend header(content-id) [uniqueID] set state(header) [array get header] } set state(version) 1.0 return } if {$state(params) ne {}} { error "-param requires -canonical" } if {$state(encoding) ne {}} { error "-encoding requires -canonical" } if {$state(header) ne {}} { error "-header requires -canonical" } if {[info exists state(parts)]} { error "-parts requires -canonical" } if {[set fileP [info exists state(file)]]} { if {[set openP [info exists state(root)]]} { # FRINK: nocheck variable $state(root) upvar 0 $state(root) root set state(fd) $root(fd) } else { set state(root) $token set state(fd) [open $state(file) RDONLY] set state(offset) 0 seek $state(fd) 0 end set state(count) [tell $state(fd)] fconfigure $state(fd) -translation binary } } set code [catch {mime::parsepart $token} result] set ecode $errorCode set einfo $errorInfo if {$fileP} { if {!$openP} { unset state(root) catch {close $state(fd)} } unset state(fd) } return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::mime::parsepart -- # # Parses the MIME headers and attempts to break up the message # into its various parts, creating a MIME token for each part. # # Arguments: # token The MIME token to parse. # # Results: # Throws an error if it has problems parsing the MIME token, # otherwise it just sets up the appropriate variables. proc ::mime::parsepart {token} { # FRINK: nocheck variable $token upvar 0 $token state if {[set fileP [info exists state(file)]]} { seek $state(fd) [set pos $state(offset)] start set last [expr {$state(offset) + $state(count) - 1}] } else { set string $state(string) } set vline {} while 1 { set blankP 0 if {$fileP} { if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} { set blankP 1 } else { incr pos [expr {$x + 1}] } } else { if {$state(lines.current) >= $state(lines.count)} { set blankP 1 set line {} } else { set line [lindex $state(lines) $state(lines.current)] incr state(lines.current) set x [string length $line] if {$x == 0} {set blankP 1} } } if {(!$blankP) && ([string last \r $line] == {$x - 1})} { set line [string range $line 0 [expr {$x - 2}]] if {$x == 1} { set blankP 1 } } if {(!$blankP) && (([ string first { } $line] == 0) || ([ string first \t $line] == 0))} { append vline \n $line continue } if {$vline eq {}} { if {$blankP} { break } set vline $line continue } if {([set x [string first : $vline]] <= 0) \ || ([set mixed [ string trimright [ string range $vline 0 [expr {$x - 1}]] ]] eq {}) } { error "improper line in header: $vline" } set value [string trim [string range $vline [expr {$x + 1}] end]] switch -- [set lower [string tolower $mixed]] { content-type { if {[info exists state(content)]} { error "multiple Content-Type fields starting with $vline" } if {![catch {set x [parsetype $token $value]}]} { set state(content) [lindex $x 0] set state(params) [lindex $x 1] } } content-md5 { } content-transfer-encoding { if {($state(encoding) ne {}) \ && ($state(encoding) ne [ string tolower $value])} { error "multiple Content-Transfer-Encoding fields starting with $vline" } set state(encoding) [string tolower $value] } mime-version { set state(version) $value } default { if {[lsearch -exact $state(lowerL) $lower] < 0} { lappend state(lowerL) $lower lappend state(mixedL) $mixed } array set header $state(header) lappend header($lower) $value set state(header) [array get header] } } if {$blankP} { break } set vline $line } if {![info exists state(content)]} { set state(content) text/plain set state(params) [list charset us-ascii] } if {![string match multipart/* $state(content)]} { if {$fileP} { set x [tell $state(fd)] incr state(count) [expr {$state(offset) - $x}] set state(offset) $x } else { # rebuild string, this is cheap and needed by other functions set state(string) [join [ lrange $state(lines) $state(lines.current) end] \n] } if {[string match message/* $state(content)]} { # FRINK: nocheck variable [set child $token-[incr state(cid)]] set state(value) parts set state(parts) $child if {$fileP} { mime::initializeaux $child \ -file $state(file) -root $state(root) \ -offset $state(offset) -count $state(count) } else { if {[info exists state(encoding)]} { set strng [join [ lrange $state(lines) $state(lines.current) end] \n] switch -- $state(encoding) { base64 - quoted-printable { set strng [$state(encoding) -mode decode -- $strng] } default {} } mime::initializeaux $child -string $strng } else { mime::initializeaux $child -lineslist [ lrange $state(lines) $state(lines.current) end] } } } return } set state(value) parts set boundary {} foreach {k v} $state(params) { if {$k eq "boundary"} { set boundary $v break } } if {$boundary eq {}} { error "boundary parameter is missing in $state(content)" } if {[string trim $boundary] eq {}} { error "boundary parameter is empty in $state(content)" } if {$fileP} { set pos [tell $state(fd)] # This variable is like 'start', for the reasons laid out # below, in the other branch of this conditional. set initialpos $pos } else { # This variable is like 'start', a list of lines in the # part. This record is made even before we find a starting # boundary and used if we run into the terminating boundary # before a starting boundary was found. In that case the lines # before the terminator as recorded by tracelines are seen as # the part, or at least we attempt to parse them as a # part. See the forceoctet and nochild flags later. We cannot # use 'start' as that records lines only after the starting # boundary was found. set tracelines [list] } set inP 0 set moreP 1 set forceoctet 0 while {$moreP} { if {$fileP} { if {$pos > $last} { # We have run over the end of the part per the outer # information without finding a terminating boundary. # We now fake the boundary and force the parser to # give any new part coming of this a mime-type of # application/octet-stream regardless of header # information. set line "--$boundary--" set x [string length $line] set forceoctet 1 } else { if {[set x [gets $state(fd) line]] < 0} { error "end-of-file encountered while parsing $state(content)" } } incr pos [expr {$x + 1}] } else { if {$state(lines.current) >= $state(lines.count)} { error "end-of-string encountered while parsing $state(content)" } else { set line [lindex $state(lines) $state(lines.current)] incr state(lines.current) set x [string length $line] } set x [string length $line] } if {[string last \r $line] == $x - 1} { set line [string range $line 0 [expr {$x - 2}]] set crlf 2 } else { set crlf 1 } if {[string first --$boundary $line] != 0} { if {$inP && !$fileP} { lappend start $line } continue } else { lappend tracelines $line } if {!$inP} { # Haven't seen the starting boundary yet. Check if the # current line contains this starting boundary. if {$line eq "--$boundary"} { # Yes. Switch parser state to now search for the # terminating boundary of the part and record where # the part begins (or initialize the recorder for the # lines in the part). set inP 1 if {$fileP} { set start $pos } else { set start [list] } continue } elseif {$line eq "--$boundary--"} { # We just saw a terminating boundary before we ever # saw the starting boundary of a part. This forces us # to stop parsing, we do this by forcing the parser # into an accepting state. We will try to create a # child part based on faked start position or recorded # lines, or, if that fails, let the current part have # no children. # As an example note the test case mime-3.7 and the # referenced file "badmail1.txt". set inP 1 if {$fileP} { set start $initialpos } else { set start $tracelines } set forceoctet 1 # Fall through. This brings to the creation of the new # part instead of searching further and possible # running over the end. } else { continue } } # Looking for the end of the current part. We accept both a # terminating boundary and the starting boundary of the next # part as the end of the current part. if {[set moreP [string compare $line --$boundary--]] \ && $line ne "--$boundary"} { # The current part has not ended, so we record the line # if we are inside a part and doing string parsing. if {$inP && !$fileP} { lappend start $line } continue } # The current part has ended. We now determine the exact # boundaries, create a mime part object for it and recursively # parse it deeper as part of that action. # FRINK: nocheck variable [set child $token-[incr state(cid)]] lappend state(parts) $child set nochild 0 if {$fileP} { if {[set count [expr {$pos - ($start + $x + $crlf + 1)}]] < 0} { set count 0 } if {$forceoctet} { set ::errorInfo {} if {[catch { mime::initializeaux $child \ -file $state(file) -root $state(root) \ -offset $start -count $count }]} { set nochild 1 set state(parts) [lrange $state(parts) 0 end-1] } } else { mime::initializeaux $child \ -file $state(file) -root $state(root) \ -offset $start -count $count } seek $state(fd) [set start $pos] start } else { if {$forceoctet} { if {[catch { mime::initializeaux $child -lineslist $start }]} { set nochild 1 set state(parts) [lrange $state(parts) 0 end-1] } } else { mime::initializeaux $child -lineslist $start } set start {} } if {$forceoctet && !$nochild} { variable $child upvar 0 $child childstate set childstate(content) application/octet-stream } set forceoctet 0 } } # ::mime::parsetype -- # # Parses the string passed in and identifies the content-type and # params strings. # # Arguments: # token The MIME token to parse. # string The content-type string that should be parsed. # # Results: # Returns the content and params for the string as a two element # tcl list. proc ::mime::parsetype {token string} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state variable typetokenL variable typelexemeL set state(input) $string set state(buffer) {} set state(lastC) LX_END set state(comment) {} set state(tokenL) $typetokenL set state(lexemeL) $typelexemeL set code [catch {mime::parsetypeaux $token $string} result] set ecode $errorCode set einfo $errorInfo unset state(input) \ state(buffer) \ state(lastC) \ state(comment) \ state(tokenL) \ state(lexemeL) return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::mime::parsetypeaux -- # # A helper function for mime::parsetype. Parses the specified # string looking for the content type and params. # # Arguments: # token The MIME token to parse. # string The content-type string that should be parsed. # # Results: # Returns the content and params for the string as a two element # tcl list. proc ::mime::parsetypeaux {token string} { # FRINK: nocheck variable $token upvar 0 $token state if {[parselexeme $token] ne "LX_ATOM"} { error [format "expecting type (found %s)" $state(buffer)] } set type [string tolower $state(buffer)] switch -- [parselexeme $token] { LX_SOLIDUS { } LX_END { if {$type ne "message"} { error "expecting type/subtype (found $type)" } return [list message/rfc822 {}] } default { error [format "expecting \"/\" (found %s)" $state(buffer)] } } if {[parselexeme $token] ne "LX_ATOM"} { error [format "expecting subtype (found %s)" $state(buffer)] } append type [string tolower /$state(buffer)] array set params {} while {1} { switch -- [parselexeme $token] { LX_END { return [list $type [array get params]] } LX_SEMICOLON { } default { error [format "expecting \";\" (found %s)" $state(buffer)] } } switch -- [parselexeme $token] { LX_END { return [list $type [array get params]] } LX_ATOM { } default { error [format "expecting attribute (found %s)" $state(buffer)] } } set attribute [string tolower $state(buffer)] if {[parselexeme $token] ne "LX_EQUALS"} { error [format "expecting \"=\" (found %s)" $state(buffer)] } switch -- [parselexeme $token] { LX_ATOM { } LX_QSTRING { set state(buffer) [ string range $state(buffer) 1 [ expr {[string length $state(buffer)] - 2}]] } default { error [format "expecting value (found %s)" $state(buffer)] } } set params($attribute) $state(buffer) } } # ::mime::finalize -- # # mime::finalize destroys a MIME part. # # If the -subordinates option is present, it specifies which # subordinates should also be destroyed. The default value is # "dynamic". # # Arguments: # token The MIME token to parse. # args Args can be optionally be of the following form: # ?-subordinates "all" | "dynamic" | "none"? # # Results: # Returns an empty string. proc ::mime::finalize {token args} { # FRINK: nocheck variable $token upvar 0 $token state array set options [list -subordinates dynamic] array set options $args switch -- $options(-subordinates) { all { #TODO: this code path is untested if {$state(value) eq "parts"} { foreach part $state(parts) { eval [linsert $args 0 mime::finalize $part] } } } dynamic { for {set cid $state(cid)} {$cid > 0} {incr cid -1} { eval [linsert $args 0 mime::finalize $token-$cid] } } none { } default { error "unknown value for -subordinates $options(-subordinates)" } } foreach name [array names state] { unset state($name) } # FRINK: nocheck unset $token } # ::mime::getproperty -- # # mime::getproperty returns the properties of a MIME part. # # The properties are: # # property value # ======== ===== # content the type/subtype describing the content # encoding the "Content-Transfer-Encoding" # params a list of "Content-Type" parameters # parts a list of tokens for the part's subordinates # size the approximate size of the content (unencoded) # # The "parts" property is present only if the MIME part has # subordinates. # # If mime::getproperty is invoked with the name of a specific # property, then the corresponding value is returned; instead, if # -names is specified, a list of all properties is returned; # otherwise, a serialized array of properties and values is returned. # # Arguments: # token The MIME token to parse. # property One of 'content', 'encoding', 'params', 'parts', and # 'size'. Defaults to returning a serialized array of # properties and values. # # Results: # Returns the properties of a MIME part proc ::mime::getproperty {token {property {}}} { # FRINK: nocheck variable $token upvar 0 $token state switch -- $property { {} { array set properties [list content $state(content) \ encoding $state(encoding) \ params $state(params) \ size [getsize $token]] if {[info exists state(parts)]} { set properties(parts) $state(parts) } return [array get properties] } -names { set names [list content encoding params] if {[info exists state(parts)]} { lappend names parts } return $names } content - encoding - params { return $state($property) } parts { if {![info exists state(parts)]} { error "MIME part is a leaf" } return $state(parts) } size { return [getsize $token] } default { error "unknown property $property" } } } # ::mime::getsize -- # # Determine the size (in bytes) of a MIME part/token # # Arguments: # token The MIME token to parse. # # Results: # Returns the size in bytes of the MIME token. proc ::mime::getsize {token} { # FRINK: nocheck variable $token upvar 0 $token state switch -- $state(value)/$state(canonicalP) { file/0 { set size $state(count) } file/1 { return [file size $state(file)] } parts/0 - parts/1 { set size 0 foreach part $state(parts) { incr size [getsize $part] } return $size } string/0 { set size [string length $state(string)] } string/1 { return [string length $state(string)] } default { error "Unknown combination \"$state(value)/$state(canonicalP)\"" } } if {$state(encoding) eq "base64"} { set size [expr {($size * 3 + 2) / 4}] } return $size } # ::mime::getheader -- # # mime::getheader returns the header of a MIME part. # # A header consists of zero or more key/value pairs. Each value is a # list containing one or more strings. # # If mime::getheader is invoked with the name of a specific key, then # a list containing the corresponding value(s) is returned; instead, # if -names is specified, a list of all keys is returned; otherwise, a # serialized array of keys and values is returned. Note that when a # key is specified (e.g., "Subject"), the list returned usually # contains exactly one string; however, some keys (e.g., "Received") # often occur more than once in the header, accordingly the list # returned usually contains more than one string. # # Arguments: # token The MIME token to parse. # key Either a key or '-names'. If it is '-names' a list # of all keys is returned. # # Results: # Returns the header of a MIME part. proc ::mime::getheader {token {key {}}} { # FRINK: nocheck variable $token upvar 0 $token state array set header $state(header) switch -- $key { {} { set result {} foreach lower $state(lowerL) mixed $state(mixedL) { lappend result $mixed $header($lower) } return $result } -names { return $state(mixedL) } default { set lower [string tolower [set mixed $key]] if {![info exists header($lower)]} { error "key $mixed not in header" } return $header($lower) } } } # ::mime::setheader -- # # mime::setheader writes, appends to, or deletes the value associated # with a key in the header. # # The value for -mode is one of: # # write: the key/value is either created or overwritten (the # default); # # append: a new value is appended for the key (creating it as # necessary); or, # # delete: all values associated with the key are removed (the # "value" parameter is ignored). # # Regardless, mime::setheader returns the previous value associated # with the key. # # Arguments: # token The MIME token to parse. # key The name of the key whose value should be set. # value The value for the header key to be set to. # args An optional argument of the form: # ?-mode "write" | "append" | "delete"? # # Results: # Returns previous value associated with the specified key. proc ::mime::setheader {token key value args} { # FRINK: nocheck variable $token upvar 0 $token state array set options [list -mode write] array set options $args switch -- [set lower [string tolower $key]] { content-md5 - content-type - content-transfer-encoding - mime-version { error "key $key may not be set" } default {# Skip key} } array set header $state(header) if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} { #TODO: this code path is not tested if {$options(-mode) eq "delete"} { error "key $key not in header" } lappend state(lowerL) $lower lappend state(mixedL) $key set result {} } else { set result $header($lower) } switch -- $options(-mode) { append { lappend header($lower) $value } delete { unset header($lower) set state(lowerL) [lreplace $state(lowerL) $x $x] set state(mixedL) [lreplace $state(mixedL) $x $x] } write { set header($lower) [list $value] } default { error "unknown value for -mode $options(-mode)" } } set state(header) [array get header] return $result } # ::mime::getbody -- # # mime::getbody returns the body of a leaf MIME part in canonical form. # # If the -command option is present, then it is repeatedly invoked # with a fragment of the body as this: # # uplevel #0 $callback [list "data" $fragment] # # (The -blocksize option, if present, specifies the maximum size of # each fragment passed to the callback.) # When the end of the body is reached, the callback is invoked as: # # uplevel #0 $callback "end" # # Alternatively, if an error occurs, the callback is invoked as: # # uplevel #0 $callback [list "error" reason] # # Regardless, the return value of the final invocation of the callback # is propagated upwards by mime::getbody. # # If the -command option is absent, then the return value of # mime::getbody is a string containing the MIME part's entire body. # # Arguments: # token The MIME token to parse. # args Optional arguments of the form: # ?-decode? ?-command callback ?-blocksize octets? ? # # Results: # Returns a string containing the MIME part's entire body, or # if '-command' is specified, the return value of the command # is returned. proc ::mime::getbody {token args} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state set decode 0 if {[set pos [lsearch -exact $args -decode]] >= 0} { set decode 1 set args [lreplace $args $pos $pos] } array set options [list -command [ list mime::getbodyaux $token] -blocksize 4096] array set options $args if {$options(-blocksize) < 1} { error "-blocksize expects a positive integer, not $options(-blocksize)" } set code 0 set ecode {} set einfo {} switch -- $state(value)/$state(canonicalP) { file/0 { set fd [open $state(file) RDONLY] set code [catch { fconfigure $fd -translation binary seek $fd [set pos $state(offset)] start set last [expr {$state(offset) + $state(count) - 1}] set fragment {} while {$pos <= $last} { if {[set cc [ expr {($last - $pos) + 1}]] > $options(-blocksize)} { set cc $options(-blocksize) } incr pos [set len [ string length [set chunk [read $fd $cc]]]] switch -exact -- $state(encoding) { base64 - quoted-printable { if {([set x [string last \n $chunk]] > 0) \ && ($x + 1 != $len)} { set chunk [string range $chunk 0 $x] seek $fd [incr pos [expr {($x + 1) - $len}]] start } set chunk [ $state(encoding) -mode decode -- $chunk] } 7bit - 8bit - binary - {} { # Bugfix for [#477088] # Go ahead, leave chunk alone } default { error "Can't handle content encoding \"$state(encoding)\"" } } append fragment $chunk set cc [expr {$options(-blocksize) - 1}] while {[string length $fragment] > $options(-blocksize)} { uplevel #0 $options(-command) [ list data [string range $fragment 0 $cc]] set fragment [ string range $fragment $options(-blocksize) end] } } if {[string length $fragment] > 0} { uplevel #0 $options(-command) [list data $fragment] } } result] set ecode $errorCode set einfo $errorInfo catch {close $fd} } file/1 { set fd [open $state(file) RDONLY] set code [catch { fconfigure $fd -translation binary while {[string length [ set fragment [read $fd $options(-blocksize)]]] > 0} { uplevel #0 $options(-command) [list data $fragment] } } result] set ecode $errorCode set einfo $errorInfo catch {close $fd} } parts/0 - parts/1 { error "MIME part isn't a leaf" } string/0 - string/1 { switch -- $state(encoding)/$state(canonicalP) { base64/0 - quoted-printable/0 { set fragment [ $state(encoding) -mode decode -- $state(string)] } default { # Not a bugfix for [#477088], but clarification # This handles no-encoding, 7bit, 8bit, and binary. set fragment $state(string) } } set code [catch { set cc [expr {$options(-blocksize) -1}] while {[string length $fragment] > $options(-blocksize)} { uplevel #0 $options(-command) [ list data [string range $fragment 0 $cc]] set fragment [ string range $fragment $options(-blocksize) end] } if {[string length $fragment] > 0} { uplevel #0 $options(-command) [list data $fragment] } } result] set ecode $errorCode set einfo $errorInfo } default { error "Unknown combination \"$state(value)/$state(canonicalP)\"" } } set code [catch { if {$code} { uplevel #0 $options(-command) [list error $result] } else { uplevel #0 $options(-command) [list end] } } result] set ecode $errorCode set einfo $errorInfo if {$code} { return -code $code -errorinfo $einfo -errorcode $ecode $result } if {$decode} { array set params [mime::getproperty $token params] if {[info exists params(charset)]} { set charset $params(charset) } else { set charset US-ASCII } set enc [reversemapencoding $charset] if {$enc ne {}} { set result [::encoding convertfrom $enc $result] } else { return -code error "-decode failed: can't reversemap charset $charset" } } return $result } # ::mime::getbodyaux -- # # Builds up the body of the message, fragment by fragment. When # the entire message has been retrieved, it is returned. # # Arguments: # token The MIME token to parse. # reason One of 'data', 'end', or 'error'. # fragment The section of data data fragment to extract a # string from. # # Results: # Returns nothing, except when called with the 'end' argument # in which case it returns a string that contains all of the # data that 'getbodyaux' has been called with. Will throw an # error if it is called with the reason of 'error'. proc ::mime::getbodyaux {token reason {fragment {}}} { # FRINK: nocheck variable $token upvar 0 $token state switch $reason { data { append state(getbody) $fragment return {} } end { if {[info exists state(getbody)]} { set result $state(getbody) unset state(getbody) } else { set result {} } return $result } error { catch {unset state(getbody)} error $reason } default { error "Unknown reason \"$reason\"" } } } # ::mime::copymessage -- # # mime::copymessage copies the MIME part to the specified channel. # # mime::copymessage operates synchronously, and uses fileevent to # allow asynchronous operations to proceed independently. # # Arguments: # token The MIME token to parse. # channel The channel to copy the message to. # # Results: # Returns nothing unless an error is thrown while the message # is being written to the channel. proc ::mime::copymessage {token channel} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state set openP [info exists state(fd)] set code [catch {mime::copymessageaux $token $channel} result] set ecode $errorCode set einfo $errorInfo if {(!$openP) && ([info exists state(fd)])} { if {![info exists state(root)]} { catch {close $state(fd)} } unset state(fd) } return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::mime::copymessageaux -- # # mime::copymessageaux copies the MIME part to the specified channel. # # Arguments: # token The MIME token to parse. # channel The channel to copy the message to. # # Results: # Returns nothing unless an error is thrown while the message # is being written to the channel. proc ::mime::copymessageaux {token channel} { # FRINK: nocheck variable $token upvar 0 $token state array set header $state(header) if {$state(version) ne {}} { puts $channel "MIME-Version: $state(version)" } foreach lower $state(lowerL) mixed $state(mixedL) { foreach value $header($lower) { puts $channel "$mixed: $value" } } if {(!$state(canonicalP)) \ && ([set encoding $state(encoding)] ne {})} { puts $channel "Content-Transfer-Encoding: $encoding" } puts -nonewline $channel "Content-Type: $state(content)" set boundary {} foreach {k v} $state(params) { if {$k eq "boundary"} { set boundary $v } puts -nonewline $channel ";\n $k=\"$v\"" } set converter {} set encoding {} if {$state(value) ne "parts"} { puts $channel {} if {$state(canonicalP)} { if {[set encoding $state(encoding)] eq {}} { set encoding [encoding $token] } if {$encoding ne {}} { puts $channel "Content-Transfer-Encoding: $encoding" } switch -- $encoding { base64 - quoted-printable { set converter $encoding } 7bit - 8bit - binary - {} { # Bugfix for [#477088], also [#539952] # Go ahead } default { error "Can't handle content encoding \"$encoding\"" } } } } elseif {([string match multipart/* $state(content)]) \ && ($boundary eq {})} { # we're doing everything in one pass... set key [clock seconds]$token[info hostname][array get state] set seqno 8 while {[incr seqno -1] >= 0} { set key [md5 -- $key] } set boundary "----- =_[string trim [base64 -mode encode -- $key]]" puts $channel ";\n boundary=\"$boundary\"" } else { puts $channel {} } if {[info exists state(error)]} { unset state(error) } switch -- $state(value) { file { set closeP 1 if {[info exists state(root)]} { # FRINK: nocheck variable $state(root) upvar 0 $state(root) root if {[info exists root(fd)]} { set fd $root(fd) set closeP 0 } else { set fd [set state(fd) [open $state(file) RDONLY]] } set size $state(count) } else { set fd [set state(fd) [open $state(file) RDONLY]] # read until eof set size -1 } seek $fd $state(offset) start if {$closeP} { fconfigure $fd -translation binary } puts $channel {} while {($size != 0) && (![eof $fd])} { if {$size < 0 || $size > 32766} { set X [read $fd 32766] } else { set X [read $fd $size] } if {$size > 0} { set size [expr {$size - [string length $X]}] } if {$converter eq {}} { puts -nonewline $channel $X } else { puts -nonewline $channel [$converter -mode encode -- $X] } } if {$closeP} { catch {close $state(fd)} unset state(fd) } } parts { if {(![info exists state(root)]) \ && ([info exists state(file)])} { set state(fd) [open $state(file) RDONLY] fconfigure $state(fd) -translation binary } switch -glob -- $state(content) { message/* { puts $channel {} foreach part $state(parts) { mime::copymessage $part $channel break } } default { # Note RFC 2046: See buildmessageaux for details. foreach part $state(parts) { puts $channel \n--$boundary mime::copymessage $part $channel } puts $channel \n--$boundary-- } } if {[info exists state(fd)]} { catch {close $state(fd)} unset state(fd) } } string { if {[catch {fconfigure $channel -buffersize} blocksize]} { set blocksize 4096 } elseif {$blocksize < 512} { set blocksize 512 } set blocksize [expr {($blocksize / 4) * 3}] # [893516] fconfigure $channel -buffersize $blocksize puts $channel {} #TODO: tests don't cover these paths if {$converter eq {}} { puts -nonewline $channel $state(string) } else { puts -nonewline $channel [$converter -mode encode -- $state(string)] } } default { error "Unknown value \"$state(value)\"" } } flush $channel if {[info exists state(error)]} { error $state(error) } } # ::mime::buildmessage -- # # The following is a clone of the copymessage code to build up the # result in memory, and, unfortunately, without using a memory channel. # I considered parameterizing the "puts" calls in copy message, but # the need for this procedure may go away, so I'm living with it for # the moment. # # Arguments: # token The MIME token to parse. # # Results: # Returns the message that has been built up in memory. proc ::mime::buildmessage {token} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state set openP [info exists state(fd)] set code [catch {mime::buildmessageaux $token} result] if {![info exists errorCode]} { set ecode {} } else { set ecode $errorCode } set einfo $errorInfo if {(!$openP) && ([info exists state(fd)])} { if {![info exists state(root)]} { catch {close $state(fd)} } unset state(fd) } return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::mime::buildmessageaux -- # # The following is a clone of the copymessageaux code to build up the # result in memory, and, unfortunately, without using a memory channel. # I considered parameterizing the "puts" calls in copy message, but # the need for this procedure may go away, so I'm living with it for # the moment. # # Arguments: # token The MIME token to parse. # # Results: # Returns the message that has been built up in memory. proc ::mime::buildmessageaux {token} { # FRINK: nocheck variable $token upvar 0 $token state array set header $state(header) set result {} if {$state(version) ne {}} { append result "MIME-Version: $state(version)\r\n" } foreach lower $state(lowerL) mixed $state(mixedL) { foreach value $header($lower) { append result "$mixed: $value\r\n" } } if {(!$state(canonicalP)) \ && ([set encoding $state(encoding)] ne {})} { append result "Content-Transfer-Encoding: $encoding\r\n" } append result "Content-Type: $state(content)" set boundary {} foreach {k v} $state(params) { if {$k eq "boundary"} { set boundary $v } append result ";\r\n $k=\"$v\"" } set converter {} set encoding {} if {$state(value) ne "parts"} { #TODO: the path is not covered by tests append result \r\n if {$state(canonicalP)} { if {[set encoding $state(encoding)] eq {}} { set encoding [encoding $token] } if {$encoding ne {}} { append result "Content-Transfer-Encoding: $encoding\r\n" } switch -- $encoding { base64 - quoted-printable { set converter $encoding } 7bit - 8bit - binary - {} { # Bugfix for [#477088] # Go ahead } default { error "Can't handle content encoding \"$encoding\"" } } } } elseif {([string match multipart/* $state(content)]) \ && ($boundary eq {})} { # we're doing everything in one pass... set key [clock seconds]$token[info hostname][array get state] set seqno 8 while {[incr seqno -1] >= 0} { set key [md5 -- $key] } set boundary "----- =_[string trim [base64 -mode encode -- $key]]" append result ";\r\n boundary=\"$boundary\"\r\n" } else { append result \r\n } if {[info exists state(error)]} { unset state(error) } switch -- $state(value) { file { set closeP 1 if {[info exists state(root)]} { # FRINK: nocheck variable $state(root) upvar 0 $state(root) root if {[info exists root(fd)]} { set fd $root(fd) set closeP 0 } else { set fd [set state(fd) [open $state(file) RDONLY]] } set size $state(count) } else { set fd [set state(fd) [open $state(file) RDONLY]] set size -1 ;# Read until EOF } seek $fd $state(offset) start if {$closeP} { fconfigure $fd -translation binary } append result \r\n while {($size != 0) && (![eof $fd])} { if {$size < 0 || $size > 32766} { set X [read $fd 32766] } else { set X [read $fd $size] } if {$size > 0} { set size [expr {$size - [string length $X]}] } if {$converter ne {}} { append result [$converter -mode encode -- $X] } else { append result $X } } if {$closeP} { catch {close $state(fd)} unset state(fd) } } parts { if {(![info exists state(root)]) \ && ([info exists state(file)])} { set state(fd) [open $state(file) RDONLY] fconfigure $state(fd) -translation binary } switch -glob -- $state(content) { message/* { append result "\r\n" foreach part $state(parts) { append result [buildmessage $part] break } } default { # Note RFC 2046: # # The boundary delimiter MUST occur at the # beginning of a line, i.e., following a CRLF, and # the initial CRLF is considered to be attached to # the boundary delimiter line rather than part of # the preceding part. # # - The above means that the CRLF before $boundary # is needed per the RFC, and the parts must not # have a closing CRLF of their own. See Tcllib bug # 1213527, and patch 1254934 for the problems when # both file/string brnaches added CRLF after the # body parts. foreach part $state(parts) { append result "\r\n--$boundary\r\n" append result [buildmessage $part] } append result "\r\n--$boundary--\r\n" } } if {[info exists state(fd)]} { catch {close $state(fd)} unset state(fd) } } string { append result "\r\n" if {$converter ne {}} { append result [$converter -mode encode -- $state(string)] } else { append result $state(string) } } default { error "Unknown value \"$state(value)\"" } } if {[info exists state(error)]} { error $state(error) } return $result } # ::mime::encoding -- # # Determines how a token is encoded. # # Arguments: # token The MIME token to parse. # # Results: # Returns the encoding of the message (the null string, base64, # or quoted-printable). proc ::mime::encoding {token} { # FRINK: nocheck variable $token upvar 0 $token state switch -glob -- $state(content) { audio/* - image/* - video/* { return base64 } message/* - multipart/* { return {} } default {# Skip} } set asciiP 1 set lineP 1 switch -- $state(value) { file { set fd [open $state(file) RDONLY] fconfigure $fd -translation binary while {[gets $fd line] >= 0} { if {$asciiP} { set asciiP [encodingasciiP $line] } if {$lineP} { set lineP [encodinglineP $line] } if {(!$asciiP) && (!$lineP)} { break } } catch {close $fd} } parts { return {} } string { foreach line [split $state(string) "\n"] { if {$asciiP} { set asciiP [encodingasciiP $line] } if {$lineP} { set lineP [encodinglineP $line] } if {(!$asciiP) && (!$lineP)} { break } } } default { error "Unknown value \"$state(value)\"" } } switch -glob -- $state(content) { text/* { if {!$asciiP} { #TODO: this path is not covered by tests foreach {k v} $state(params) { if {$k eq "charset"} { set v [string tolower $v] if {($v ne "us-ascii") \ && (![string match {iso-8859-[1-8]} $v])} { return base64 } break } } } if {!$lineP} { return quoted-printable } } default { if {(!$asciiP) || (!$lineP)} { return base64 } } } return {} } # ::mime::encodingasciiP -- # # Checks if a string is a pure ascii string, or if it has a non-standard # form. # # Arguments: # line The line to check. # # Results: # Returns 1 if \r only occurs at the end of lines, and if all # characters in the line are between the ASCII codes of 32 and 126. proc ::mime::encodingasciiP {line} { foreach c [split $line {}] { switch -- $c { { } - \t - \r - \n { } default { binary scan $c c c if {($c < 32) || ($c > 126)} { return 0 } } } } if {([set r [string first \r $line]] < 0) \ || ($r == {[string length $line] - 1})} { return 1 } return 0 } # ::mime::encodinglineP -- # # Checks if a string is a line is valid to be processed. # # Arguments: # line The line to check. # # Results: # Returns 1 the line is less than 76 characters long, the line # contains more characters than just whitespace, the line does # not start with a '.', and the line does not start with 'From '. proc ::mime::encodinglineP {line} { if {([string length $line] > 76) \ || ($line ne [string trimright $line]) \ || ([string first . $line] == 0) \ || ([string first {From } $line] == 0)} { return 0 } return 1 } # ::mime::fcopy -- # # Appears to be unused. # # Arguments: # # Results: # proc ::mime::fcopy {token count {error {}}} { # FRINK: nocheck variable $token upvar 0 $token state if {$error ne {}} { set state(error) $error } set state(doneP) 1 } # ::mime::scopy -- # # Copy a portion of the contents of a mime token to a channel. # # Arguments: # token The token containing the data to copy. # channel The channel to write the data to. # offset The location in the string to start copying # from. # len The amount of data to write. # blocksize The block size for the write operation. # # Results: # The specified portion of the string in the mime token is # copied to the specified channel. proc ::mime::scopy {token channel offset len blocksize} { # FRINK: nocheck variable $token upvar 0 $token state if {$len <= 0} { set state(doneP) 1 fileevent $channel writable {} return } if {[set cc $len] > $blocksize} { set cc $blocksize } if {[catch { puts -nonewline $channel [ string range $state(string) $offset [expr {$offset + $cc - 1}]] fileevent $channel writable [ list mime::scopy $token $channel [ incr offset $cc] [incr len -$cc] $blocksize] } result]} { set state(error) $result set state(doneP) 1 fileevent $channel writable {} } return } # ::mime::qp_encode -- # # Tcl version of quote-printable encode # # Arguments: # string The string to quote. # encoded_word Boolean value to determine whether or not encoded words # (RFC 2047) should be handled or not. (optional) # # Results: # The properly quoted string is returned. proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} { # 8.1+ improved string manipulation routines used. # Replace outlying characters, characters that would normally # be munged by EBCDIC gateways, and special Tcl characters "[\]{} # with =xx sequence regsub -all -- \ {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \ $string {[format =%02X [scan "\\&" %c]]} string # Replace the format commands with their result set string [subst -novariables $string] # soft/hard newlines and other # Funky cases for SMTP compatibility set mapChars [ list " \n" =20\n \t\n =09\n \n\.\n \=2E\n "\nFrom " "\n=46rom "] if {$encoded_word} { # Special processing for encoded words (RFC 2047) lappend mapChars { } _ } set string [string map $mapChars $string] # Break long lines - ugh # Implementation of FR #503336 if {$no_softbreak} { set result $string } else { set result {} foreach line [split $string \n] { while {[string length $line] > 72} { set chunk [string range $line 0 72] if {[regexp -- (=|=.)$ $chunk dummy end]} { # Don't break in the middle of a code set len [expr {72 - [string length $end]}] set chunk [string range $line 0 $len] incr len set line [string range $line $len end] } else { set line [string range $line 73 end] } append result $chunk=\n } append result $line\n } # Trim off last \n, since the above code has the side-effect # of adding an extra \n to the encoded string and return the # result. set result [string range $result 0 end-1] } # If the string ends in space or tab, replace with =xx set lastChar [string index $result end] if {$lastChar eq { }} { set result [string replace $result end end =20] } elseif {$lastChar eq "\t"} { set result [string replace $result end end =09] } return $result } # ::mime::qp_decode -- # # Tcl version of quote-printable decode # # Arguments: # string The quoted-prinatble string to decode. # encoded_word Boolean value to determine whether or not encoded words # (RFC 2047) should be handled or not. (optional) # # Results: # The decoded string is returned. proc ::mime::qp_decode {string {encoded_word 0}} { # 8.1+ improved string manipulation routines used. # Special processing for encoded words (RFC 2047) if {$encoded_word} { # _ == \x20, even if SPACE occupies a different code position set string [string map [list _ \u0020] $string] } # smash the white-space at the ends of lines since that must've been # generated by an MUA. regsub -all -- {[ \t]+\n} $string \n string set string [string trimright $string " \t"] # Protect the backslash for later subst and # smash soft newlines, has to occur after white-space smash # and any encoded word modification. #TODO: codepath not tested set string [string map [list \\ {\\} =\n {}] $string] # Decode specials regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string # process \u unicode mapped chars return [subst -novariables -nocommands $string] } # ::mime::parseaddress -- # # This was originally written circa 1982 in C. we're still using it # because it recognizes virtually every buggy address syntax ever # generated! # # mime::parseaddress takes a string containing one or more 822-style # address specifications and returns a list of serialized arrays, one # element for each address specified in the argument. # # Each serialized array contains these properties: # # property value # ======== ===== # address local@domain # comment 822-style comment # domain the domain part (rhs) # error non-empty on a parse error # group this address begins a group # friendly user-friendly rendering # local the local part (lhs) # memberP this address belongs to a group # phrase the phrase part # proper 822-style address specification # route 822-style route specification (obsolete) # # Note that one or more of these properties may be empty. # # Arguments: # string The address string to parse # # Results: # Returns a list of serialized arrays, one element for each address # specified in the argument. proc ::mime::parseaddress {string} { global errorCode errorInfo variable mime set token [namespace current]::[incr mime(uid)] # FRINK: nocheck variable $token upvar 0 $token state set code [catch {mime::parseaddressaux $token $string} result] set ecode $errorCode set einfo $errorInfo foreach name [array names state] { unset state($name) } # FRINK: nocheck catch {unset $token} return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::mime::parseaddressaux -- # # This was originally written circa 1982 in C. we're still using it # because it recognizes virtually every buggy address syntax ever # generated! # # mime::parseaddressaux does the actually parsing for mime::parseaddress # # Each serialized array contains these properties: # # property value # ======== ===== # address local@domain # comment 822-style comment # domain the domain part (rhs) # error non-empty on a parse error # group this address begins a group # friendly user-friendly rendering # local the local part (lhs) # memberP this address belongs to a group # phrase the phrase part # proper 822-style address specification # route 822-style route specification (obsolete) # # Note that one or more of these properties may be empty. # # Arguments: # token The MIME token to work from. # string The address string to parse # # Results: # Returns a list of serialized arrays, one element for each address # specified in the argument. proc ::mime::parseaddressaux {token string} { # FRINK: nocheck variable $token upvar 0 $token state variable addrtokenL variable addrlexemeL set state(input) $string set state(glevel) 0 set state(buffer) {} set state(lastC) LX_END set state(tokenL) $addrtokenL set state(lexemeL) $addrlexemeL set result {} while {[addr_next $token]} { if {[set tail $state(domain)] ne {}} { set tail @$state(domain) } else { set tail @[info hostname] } if {[set address $state(local)] ne {}} { #TODO: this path is not covered by tests append address $tail } if {$state(phrase) ne {}} { #TODO: this path is not covered by tests set state(phrase) [string trim $state(phrase) \"] foreach t $state(tokenL) { if {[string first $t $state(phrase)] >= 0} { #TODO: is this quoting robust enough? set state(phrase) \"$state(phrase)\" break } } set proper "$state(phrase) <$address>" } else { set proper $address } if {[set friendly $state(phrase)] eq {}} { #TODO: this path is not covered by tests if {[set note $state(comment)] ne {}} { if {[string first ( $note] == 0} { set note [string trimleft [string range $note 1 end]] } if {[string last ) $note] \ == [set len [expr {[string length $note] - 1}]]} { set note [string range $note 0 [expr {$len - 1}]] } set friendly $note } if {($friendly eq {}) \ && ([set mbox $state(local)] ne {})} { #TODO: this path is not covered by tests set mbox [string trim $mbox \"] if {[string first / $mbox] != 0} { set friendly $mbox } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} { } elseif {([set friendly [addr_x400 $mbox S]] ne {}) \ && ([set g [addr_x400 $mbox G]] ne {})} { set friendly "$g $friendly" } if {$friendly eq {}} { set friendly $mbox } } } set friendly [string trim $friendly \"] lappend result [list address $address \ comment $state(comment) \ domain $state(domain) \ error $state(error) \ friendly $friendly \ group $state(group) \ local $state(local) \ memberP $state(memberP) \ phrase $state(phrase) \ proper $proper \ route $state(route)] } unset state(input) \ state(glevel) \ state(buffer) \ state(lastC) \ state(tokenL) \ state(lexemeL) return $result } # ::mime::addr_next -- # # Locate the next address in a mime token. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_next {token} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state set nocomplain [package vsatisfies [package provide Tcl] 8.4] foreach prop {comment domain error group local memberP phrase route} { if {$nocomplain} { unset -nocomplain state($prop) } else { if {[catch {unset state($prop)}]} {set ::errorInfo {}} } } switch -- [set code [catch {mime::addr_specification $token} result]] { 0 { if {!$result} { return 0 } switch -- $state(lastC) { LX_COMMA - LX_END { } default { # catch trailing comments... set lookahead $state(input) mime::parselexeme $token set state(input) $lookahead } } } 7 { set state(error) $result while {1} { switch -- $state(lastC) { LX_COMMA - LX_END { break } default { mime::parselexeme $token } } } } default { set ecode $errorCode set einfo $errorInfo return -code $code -errorinfo $einfo -errorcode $ecode $result } } foreach prop {comment domain error group local memberP phrase route} { if {![info exists state($prop)]} { set state($prop) {} } } return 1 } # ::mime::addr_specification -- # # Uses lookahead parsing to determine whether there is another # valid e-mail address or not. Throws errors if unrecognized # or invalid e-mail address syntax is used. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_specification {token} { # FRINK: nocheck variable $token upvar 0 $token state set lookahead $state(input) switch -- [parselexeme $token] { LX_ATOM - LX_QSTRING { set state(phrase) $state(buffer) } LX_SEMICOLON { if {[incr state(glevel) -1] < 0} { return -code 7 "extraneous semi-colon" } catch {unset state(comment)} return [addr_specification $token] } LX_COMMA { catch {unset state(comment)} return [addr_specification $token] } LX_END { return 0 } LX_LBRACKET { return [addr_routeaddr $token] } LX_ATSIGN { set state(input) $lookahead return [addr_routeaddr $token 0] } default { return -code 7 \ [format "unexpected character at beginning (found %s)" \ $state(buffer)] } } switch -- [parselexeme $token] { LX_ATOM - LX_QSTRING { append state(phrase) " " $state(buffer) return [addr_phrase $token] } LX_LBRACKET { return [addr_routeaddr $token] } LX_COLON { return [addr_group $token] } LX_DOT { set state(local) "$state(phrase)$state(buffer)" unset state(phrase) mime::addr_routeaddr $token 0 mime::addr_end $token } LX_ATSIGN { set state(memberP) $state(glevel) set state(local) $state(phrase) unset state(phrase) mime::addr_domain $token mime::addr_end $token } LX_SEMICOLON - LX_COMMA - LX_END { set state(memberP) $state(glevel) if {($state(lastC) eq "LX_SEMICOLON") \ && ([incr state(glevel) -1] < 0)} { #TODO: this path is not covered by tests return -code 7 "extraneous semi-colon" } set state(local) $state(phrase) unset state(phrase) } default { return -code 7 [ format "expecting mailbox (found %s)" $state(buffer)] } } return 1 } # ::mime::addr_routeaddr -- # # Parses the domain portion of an e-mail address. Finds the '@' # sign and then calls mime::addr_route to verify the domain. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_routeaddr {token {checkP 1}} { # FRINK: nocheck variable $token upvar 0 $token state set lookahead $state(input) if {[parselexeme $token] eq "LX_ATSIGN"} { #TODO: this path is not covered by tests mime::addr_route $token } else { set state(input) $lookahead } mime::addr_local $token switch -- $state(lastC) { LX_ATSIGN { mime::addr_domain $token } LX_SEMICOLON - LX_RBRACKET - LX_COMMA - LX_END { } default { return -code 7 [ format "expecting at-sign after local-part (found %s)" \ $state(buffer)] } } if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} { return -code 7 [ format "expecting right-bracket (found %s)" $state(buffer)] } return 1 } # ::mime::addr_route -- # # Attempts to parse the portion of the e-mail address after the @. # Tries to verify that the domain definition has a valid form. # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_route {token} { # FRINK: nocheck variable $token upvar 0 $token state set state(route) @ while {1} { switch -- [parselexeme $token] { LX_ATOM - LX_DLITERAL { append state(route) $state(buffer) } default { return -code 7 \ [format "expecting sub-route in route-part (found %s)" \ $state(buffer)] } } switch -- [parselexeme $token] { LX_COMMA { append state(route) $state(buffer) while {1} { switch -- [parselexeme $token] { LX_COMMA { } LX_ATSIGN { append state(route) $state(buffer) break } default { return -code 7 \ [format "expecting at-sign in route (found %s)" \ $state(buffer)] } } } } LX_ATSIGN - LX_DOT { append state(route) $state(buffer) } LX_COLON { append state(route) $state(buffer) return } default { return -code 7 \ [format "expecting colon to terminate route (found %s)" \ $state(buffer)] } } } } # ::mime::addr_domain -- # # Attempts to parse the portion of the e-mail address after the @. # Tries to verify that the domain definition has a valid form. # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_domain {token} { # FRINK: nocheck variable $token upvar 0 $token state while {1} { switch -- [parselexeme $token] { LX_ATOM - LX_DLITERAL { append state(domain) $state(buffer) } default { return -code 7 \ [format "expecting sub-domain in domain-part (found %s)" \ $state(buffer)] } } switch -- [parselexeme $token] { LX_DOT { append state(domain) $state(buffer) } LX_ATSIGN { append state(local) % $state(domain) unset state(domain) } default { return } } } } # ::mime::addr_local -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_local {token} { # FRINK: nocheck variable $token upvar 0 $token state set state(memberP) $state(glevel) while {1} { switch -- [parselexeme $token] { LX_ATOM - LX_QSTRING { append state(local) $state(buffer) } default { return -code 7 \ [format "expecting mailbox in local-part (found %s)" \ $state(buffer)] } } switch -- [parselexeme $token] { LX_DOT { append state(local) $state(buffer) } default { return } } } } # ::mime::addr_phrase -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_phrase {token} { # FRINK: nocheck variable $token upvar 0 $token state while {1} { switch -- [parselexeme $token] { LX_ATOM - LX_QSTRING { append state(phrase) " " $state(buffer) } default { break } } } switch -- $state(lastC) { LX_LBRACKET { return [addr_routeaddr $token] } LX_COLON { return [addr_group $token] } LX_DOT { append state(phrase) $state(buffer) return [addr_phrase $token] } default { return -code 7 \ [format "found phrase instead of mailbox (%s%s)" \ $state(phrase) $state(buffer)] } } } # ::mime::addr_group -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_group {token} { # FRINK: nocheck variable $token upvar 0 $token state if {[incr state(glevel)] > 1} { return -code 7 [format "nested groups not allowed (found %s)" \ $state(phrase)] } set state(group) $state(phrase) unset state(phrase) set lookahead $state(input) while {1} { switch -- [parselexeme $token] { LX_SEMICOLON - LX_END { set state(glevel) 0 return 1 } LX_COMMA { } default { set state(input) $lookahead return [addr_specification $token] } } } } # ::mime::addr_end -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_end {token} { # FRINK: nocheck variable $token upvar 0 $token state switch -- $state(lastC) { LX_SEMICOLON { if {[incr state(glevel) -1] < 0} { return -code 7 "extraneous semi-colon" } } LX_COMMA - LX_END { } default { return -code 7 [format "junk after local@domain (found %s)" \ $state(buffer)] } } } # ::mime::addr_x400 -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_x400 {mbox key} { if {[set x [string first /$key= [string toupper $mbox]]] < 0} { return {} } set mbox [string range $mbox [expr {$x + [string length $key] + 2}] end] if {[set x [string first / $mbox]] > 0} { set mbox [string range $mbox 0 [expr {$x - 1}]] } return [string trim $mbox \"] } # ::mime::parsedatetime -- # # Fortunately the clock command in the Tcl 8.x core does all the heavy # lifting for us (except for timezone calculations). # # mime::parsedatetime takes a string containing an 822-style date-time # specification and returns the specified property. # # The list of properties and their ranges are: # # property range # ======== ===== # clock raw result of "clock scan" # hour 0 .. 23 # lmonth January, February, ..., December # lweekday Sunday, Monday, ... Saturday # mday 1 .. 31 # min 0 .. 59 # mon 1 .. 12 # month Jan, Feb, ..., Dec # proper 822-style date-time specification # rclock elapsed seconds between then and now # sec 0 .. 59 # wday 0 .. 6 (Sun .. Mon) # weekday Sun, Mon, ..., Sat # yday 1 .. 366 # year 1900 ... # zone -720 .. 720 (minutes east of GMT) # # Arguments: # value Either a 822-style date-time specification or '-now' # if the current date/time should be used. # property The property (from the list above) to return # # Results: # Returns the string value of the 'property' for the date/time that was # specified in 'value'. namespace eval ::mime { variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat] variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \ Friday Saturday] # Counting months starts at 1, so just insert a dummy element # at index 0. variable MONTHS_SHORT [list {} \ Jan Feb Mar Apr May Jun \ Jul Aug Sep Oct Nov Dec] variable MONTHS_LONG [list {} \ January February March April May June July \ August Sepember October November December] } proc ::mime::parsedatetime {value property} { if {$value eq "-now"} { set clock [clock seconds] } elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \ -> value zone_sign zone_hour zone_min]} { set clock [clock scan $value -gmt 1] if {[info exists zone_min]} { set zone_min [scan $zone_min %d] set zone_hour [scan $zone_hour %d] set zone [expr {60 * ($zone_min + 60 * $zone_hour)}] if {$zone_sign eq "+"} { set zone -$zone } incr clock $zone } } else { set clock [clock scan $value] } switch -- $property { clock { return $clock } hour { set value [clock format $clock -format %H] } lmonth { variable MONTHS_LONG return [lindex $MONTHS_LONG \ [scan [clock format $clock -format %m] %d]] } lweekday { variable WDAYS_LONG return [lindex $WDAYS_LONG [clock format $clock -format %w]] } mday { set value [clock format $clock -format %d] } min { set value [clock format $clock -format %M] } mon { set value [clock format $clock -format %m] } month { variable MONTHS_SHORT return [lindex $MONTHS_SHORT \ [scan [clock format $clock -format %m] %d]] } proper { set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" \ -gmt true] if {[set diff [expr {($clock-[clock scan $gmt]) / 60}]] < 0} { set s - set diff [expr {-($diff)}] } else { set s + } set zone [format %s%02d%02d $s [ expr {$diff / 60}] [expr {$diff % 60}]] variable WDAYS_SHORT set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]] variable MONTHS_SHORT set mon [lindex $MONTHS_SHORT \ [scan [clock format $clock -format %m] %d]] return [clock format $clock \ -format "$wday, %d $mon %Y %H:%M:%S $zone"] } rclock { #TODO: these paths are not covered by tests if {$value eq "-now"} { return 0 } else { return [expr {[clock seconds] - $clock}] } } sec { set value [clock format $clock -format %S] } wday { return [clock format $clock -format %w] } weekday { variable WDAYS_SHORT return [lindex $WDAYS_SHORT [clock format $clock -format %w]] } yday { set value [clock format $clock -format %j] } year { set value [clock format $clock -format %Y] } zone { set value [string trim [string map [list \t { }] $value]] if {[set x [string last { } $value]] < 0} { return 0 } set value [string range $value [expr {$x + 1}] end] switch -- [set s [string index $value 0]] { + - - { if {$s eq "+"} { #TODO: This path is not covered by tests set s {} } set value [string trim [string range $value 1 end]] if {([string length $value] != 4) \ || ([scan $value %2d%2d h m] != 2) \ || ($h > 12) \ || ($m > 59) \ || (($h == 12) && ($m > 0))} { error "malformed timezone-specification: $value" } set value $s[expr {$h * 60 + $m}] } default { set value [string toupper $value] set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT] set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7] if {[set x [lsearch -exact $z1 $value]] < 0} { error "unrecognized timezone-mnemonic: $value" } set value [expr {[lindex $z2 $x] * 60}] } } } date2gmt - date2local - dst - sday - szone - tzone - default { error "unknown property $property" } } if {[set value [string trimleft $value 0]] eq {}} { #TODO: this path is not covered by tests set value 0 } return $value } # ::mime::uniqueID -- # # Used to generate a 'globally unique identifier' for the content-id. # The id is built from the pid, the current time, the hostname, and # a counter that is incremented each time a message is sent. # # Arguments: # # Results: # Returns the a string that contains the globally unique identifier # that should be used for the Content-ID of an e-mail message. proc ::mime::uniqueID {} { variable mime return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>" } # ::mime::parselexeme -- # # Used to implement a lookahead parser. # # Arguments: # token The MIME token to operate on. # # Results: # Returns the next token found by the parser. proc ::mime::parselexeme {token} { # FRINK: nocheck variable $token upvar 0 $token state set state(input) [string trimleft $state(input)] set state(buffer) {} if {$state(input) eq {}} { set state(buffer) end-of-input return [set state(lastC) LX_END] } set c [string index $state(input) 0] set state(input) [string range $state(input) 1 end] if {$c eq "("} { set noteP 0 set quoteP 0 while 1 { append state(buffer) $c #TODO: some of these paths are not covered by tests switch -- $c/$quoteP { (/0 { incr noteP } \\/0 { set quoteP 1 } )/0 { if {[incr noteP -1] < 1} { if {[info exists state(comment)]} { append state(comment) { } } append state(comment) $state(buffer) return [parselexeme $token] } } default { set quoteP 0 } } if {[set c [string index $state(input) 0]] eq {}} { set state(buffer) "end-of-input during comment" return [set state(lastC) LX_ERR] } set state(input) [string range $state(input) 1 end] } } if {$c eq "\""} { set firstP 1 set quoteP 0 while 1 { append state(buffer) $c switch -- $c/$quoteP { "\\/0" { set quoteP 1 } "\"/0" { if {!$firstP} { return [set state(lastC) LX_QSTRING] } set firstP 0 } default { set quoteP 0 } } if {[set c [string index $state(input) 0]] eq {}} { set state(buffer) "end-of-input during quoted-string" return [set state(lastC) LX_ERR] } set state(input) [string range $state(input) 1 end] } } if {$c eq {[}} { set quoteP 0 while 1 { append state(buffer) $c switch -- $c/$quoteP { \\/0 { set quoteP 1 } ]/0 { return [set state(lastC) LX_DLITERAL] } default { set quoteP 0 } } if {[set c [string index $state(input) 0]] eq {}} { set state(buffer) "end-of-input during domain-literal" return [set state(lastC) LX_ERR] } set state(input) [string range $state(input) 1 end] } } if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { append state(buffer) $c return [set state(lastC) [lindex $state(lexemeL) $x]] } while {1} { append state(buffer) $c switch -- [set c [string index $state(input) 0]] { {} - " " - "\t" - "\n" { break } default { if {[lsearch -exact $state(tokenL) $c] >= 0} { break } } } set state(input) [string range $state(input) 1 end] } return [set state(lastC) LX_ATOM] } # ::mime::mapencoding -- # # mime::mapencodings maps tcl encodings onto the proper names for their # MIME charset type. This is only done for encodings whose charset types # were known. The remaining encodings return {} for now. # # Arguments: # enc The tcl encoding to map. # # Results: # Returns the MIME charset type for the specified tcl encoding, or {} # if none is known. proc ::mime::mapencoding {enc} { variable encodings if {[info exists encodings($enc)]} { return $encodings($enc) } return {} } # ::mime::reversemapencoding -- # # mime::reversemapencodings maps MIME charset types onto tcl encoding names. # Those that are unknown return {}. # # Arguments: # mimeType The MIME charset to convert into a tcl encoding type. # # Results: # Returns the tcl encoding name for the specified mime charset, or {} # if none is known. proc ::mime::reversemapencoding {mimeType} { variable reversemap set lmimeType [string tolower $mimeType] if {[info exists reversemap($lmimeType)]} { return $reversemap($lmimeType) } return {} } # ::mime::word_encode -- # # Word encodes strings as per RFC 2047. # # Arguments: # charset The character set to encode the message to. # method The encoding method (base64 or quoted-printable). # string The string to encode. # ?-charset_encoded 0 or 1 Whether the data is already encoded # in the specified charset (default 1) # ?-maxlength maxlength The maximum length of each encoded # word to return (default 66) # # Results: # Returns a word encoded string. proc ::mime::word_encode {charset method string {args}} { variable encodings if {![info exists encodings($charset)]} { error "unknown charset '$charset'" } if {$encodings($charset) eq {}} { error "invalid charset '$charset'" } if {$method ne "base64" && $method ne "quoted-printable"} { error "unknown method '$method', must be base64 or quoted-printable" } # default to encoded and a length that won't make the Subject header to long array set options [list -charset_encoded 1 -maxlength 66] array set options $args if {$options(-charset_encoded)} { set unencoded_string [::encoding convertfrom $charset $string] } else { set unencoded_string $string } set string_length [string length $unencoded_string] if {!$string_length} { return {} } set string_bytelength [string bytelength $unencoded_string] # the 7 is for =?, ?Q?, ?= delimiters of the encoded word set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}] switch -exact -- $method { base64 { if {$maxlength < 4} { error "maxlength $options(-maxlength) too short for chosen charset and encoding" } set count 0 set maxlength [expr {($maxlength / 4) * 3}] while {$count < $string_length} { set length 0 set enc_string {} while {($length < $maxlength) && ($count < $string_length)} { set char [string range $unencoded_string $count $count] set enc_char [::encoding convertto $charset $char] if {($length + [string length $enc_char]) > $maxlength} { set length $maxlength } else { append enc_string $enc_char incr count incr length [string length $enc_char] } } set encoded_word [string map [ list \n {}] [base64 -mode encode -- $enc_string]] append result "=?$encodings($charset)?B?$encoded_word?=\n " } # Trim off last "\n ", since the above code has the side-effect # of adding an extra "\n " to the encoded string. set result [string range $result 0 end-2] } quoted-printable { if {$maxlength < 1} { error "maxlength $options(-maxlength) too short for chosen charset and encoding" } set count 0 while {$count < $string_length} { set length 0 set encoded_word {} while {($length < $maxlength) && ($count < $string_length)} { set char [string range $unencoded_string $count $count] set enc_char [::encoding convertto $charset $char] set qp_enc_char [qp_encode $enc_char 1] set qp_enc_char_length [string length $qp_enc_char] if {$qp_enc_char_length > $maxlength} { error "maxlength $options(-maxlength) too short for chosen charset and encoding" } if {($length + [ string length $qp_enc_char]) > $maxlength} { set length $maxlength } else { append encoded_word $qp_enc_char incr count incr length [string length $qp_enc_char] } } append result "=?$encodings($charset)?Q?$encoded_word?=\n " } # Trim off last "\n ", since the above code has the side-effect # of adding an extra "\n " to the encoded string. set result [string range $result 0 end-2] } {} { # Go ahead } default { error "Can't handle content encoding \"$method\"" } } return $result } # ::mime::word_decode -- # # Word decodes strings that have been word encoded as per RFC 2047. # # Arguments: # encoded The word encoded string to decode. # # Results: # Returns the string that has been decoded from the encoded message. proc ::mime::word_decode {encoded} { variable reversemap if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \ - charset method string] != 1} { error "malformed word-encoded expression '$encoded'" } set enc [reversemapencoding $charset] if {$enc eq {}} { error "unknown charset '$charset'" } switch -exact -- $method { b - B { set method base64 } q - Q { set method quoted-printable } default { error "unknown method '$method', must be B or Q" } } switch -exact -- $method { base64 { set result [base64 -mode decode -- $string] } quoted-printable { set result [qp_decode $string 1] } {} { # Go ahead } default { error "Can't handle content encoding \"$method\"" } } return [list $enc $method $result] } # ::mime::field_decode -- # # Word decodes strings that have been word encoded as per RFC 2047 # and converts the string from the original encoding/charset to UTF. # # Arguments: # field The string to decode # # Results: # Returns the decoded string in UTF. proc ::mime::field_decode {field} { # ::mime::field_decode is broken. Here's a new version. # This code is in the public domain. Don Libes <[email protected]> # Step through a field for mime-encoded words, building a new # version with unencoded equivalents. # Sorry about the grotesque regexp. Most of it is sensible. One # notable fudge: the final $ is needed because of an apparent bug # in the regexp engine where the preceding .* otherwise becomes # non-greedy - perhaps because of the earlier ".*?", sigh. while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} { # don't allow whitespace between encoded words per RFC 2047 if {{} != $prefix} { if {![string is space $prefix]} { append result $prefix } } set decoded [word_decode $encoded] foreach {charset - string} $decoded break append result [::encoding convertfrom $charset $string] } append result $field return $result } ## One-Shot Initialization ::apply {{} { variable encList variable encAliasList variable reversemap foreach {enc mimeType} $encList { if {$mimeType eq {}} continue set reversemap([string tolower $mimeType]) $enc } foreach {enc mimeType} $encAliasList { set reversemap([string tolower $mimeType]) $enc } # Drop the helper variables unset encList encAliasList } ::mime} |
Added modules/mime/mime-1.6.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | # mime.test - Test suite for TclMIME -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # # RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { # This code loads md5x, i.e. md5 v2. Proper testing should do one # run using md5 v1, aka md5.tcl as well. use md5/md5x.tcl md5 } testing { useLocal mime.tcl mime } # ------------------------------------------------------------------------- namespace import mime::* # ------------------------------------------------------------------------- test mime-1.1 {initialize with no args} { catch {initialize} res subst $res } {specify exactly one of -file, -parts, or -string} test mime-2.1 {Generate a MIME message} { set tok [initialize -canonical "Text/plain" -string "jack and jill"] set msg [mime::buildmessage $tok] # The generated message is predictable except for the Content-ID regexp "MIME-Version: 1.0\r Content-ID: \[^\n]+\r Content-Type: text/plain\r \r jack and jill" $msg } 1 test mime-2.2 {Generate a multi-part MIME message} { set tok1 [initialize -canonical "Text/plain" -string "jack and jill"] set tok2 [initialize -canonical "Text/plain" -string "james"] set bigTok [mime::initialize -canonical Multipart/MyType \ -param [list MyParam foo] \ -param [list boundary bndry] \ -header [list Content-Description "Test Multipart"] \ -parts [list $tok1 $tok2]] set msg [mime::buildmessage $bigTok] # The generated message is predictable except for the Content-ID list [regexp "MIME-Version: 1.0\r Content-Description: Test Multipart\r Content-ID: \[^\n]+\r Content-Type: multipart/mytype;\r \[^\n]+;\r \[^\n]+\r \r --bndry\r MIME-Version: 1.0\r Content-ID: \[^\n]+\r Content-Type: text/plain\r \r jack and jill\r --bndry\r MIME-Version: 1.0\r Content-ID: \[^\n]+\r Content-Type: text/plain\r \r james\r --bndry--\r " $msg] [regexp "boundary=\"bndry\"" $msg] [regexp "myparam=\"foo\"" $msg] } {1 1 1} test mime-3.1 {Parse a MIME message} { set msg {MIME-Version: 1.0 Content-Type: Text/plain I'm the message.} set tok [mime::initialize -string $msg] mime::getbody $tok } "I'm the message." test mime-3.2 {Parse a multi-part MIME message} { set msg {MIME-Version: 1.0 Content-Type: Multipart/foo; boundary="bar" --bar MIME-Version: 1.0 Content-Type: Text/plain part1 --bar MIME-Version: 1.0 Content-Type: Text/plain part2 --bar MIME-Version: 1.0 Content-Type: Text/plain part3 --bar-- } set tok [mime::initialize -string $msg] set partToks [mime::getproperty $tok parts] set res "" foreach childTok $partToks { lappend res [mime::getbody $childTok] } set res } {part1 part2 part3} test mime-3.3 {Try to parse a totally invalid message} { catch {mime::initialize -string "blah"} err0 set err0 } {improper line in header: blah} test mime-3.4 {Try to parse a MIME message with an invalid version} { set msg1 {MIME-Version: 2.0 Content-Type: text/plain msg1} set tok [mime::initialize -string $msg1] catch {mime::getbody $tok} err1 catch {mime::buildmessage $tok} err1a list $err1 $err1a } "msg1 {MIME-Version: 2.0\r Content-Type: text/plain\r \r msg1}" test mime-3.5 {Try to parse a MIME message with no newline between headers and data} { set msg2 {MIME-Version: 1.0 Content-Type: foobar data without newline} catch {mime::initialize -string $msg2} err2 set err2 } {improper line in header: data without newline} test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} { # No MIME version set msg3 {Content-Type: text/plain foo} set tok [mime::initialize -string $msg3] catch {mime::getbody $tok} err3 catch {mime::buildmessage $tok} err3a list $err3 $err3a } "foo {MIME-Version: 1.0\r Content-Type: text/plain\r \r foo}" test mime-3.7 {Test mime with a bad email [SF Bug 631314 ]} { set tok [mime::initialize -file \ [file join $tcltest::testsDirectory badmail1.txt]] set res {} set ctok [lindex [mime::getproperty $tok parts] 0] lappend res [dictsort [mime::getproperty $tok]] lappend res [dictsort [mime::getproperty $ctok]] mime::finalize $tok string map [list $ctok CHILD] $res } {{content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {charset us-ascii} size 0}} test mime-3.8 {Test mime with another bad email [SF Bug 631314 ]} { set tok [mime::initialize -file \ [file join $tcltest::testsDirectory badmail2.txt]] set res {} set ctok [lindex [mime::getproperty $tok parts] 0] lappend res [dictsort [mime::getproperty $tok]] lappend res [dictsort [mime::getproperty $ctok]] mime::finalize $tok string map [list $ctok CHILD] $res } {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 659} {content application/octet-stream encoding base64 params {} size 659}} test mime-3.9 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back} { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Fran\xE7ois } set tok [mime::initialize -string $msg] mime::getbody $tok -decode } {Fran\xE7ois } test mime-3.10 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back (example from encoding man page)} { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=EUC-JP Content-Transfer-Encoding: quoted-printable =A4=CF} set tok [mime::initialize -string $msg] mime::getbody $tok -decode } "\u306F" test mime-3.11 {Parse a MIME message without a charset encoded body and use getbody -decode to get it back} { set msg {MIME-Version: 1.0 Content-Type: text/plain Content-Transfer-Encoding: quoted-printable A plain text message.} set tok [mime::initialize -string $msg] mime::getbody $tok -decode } "A plain text message." test mime-3.12 {Parse a MIME message with a charset encoded body in an unrecognised charset and use getbody -decode to attempt to get it back} { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=SCRIBBLE Content-Transfer-Encoding: quoted-printable This is a message in the scribble charset that tcl does not recognise.} set tok [mime::initialize -string $msg] catch {mime::getbody $tok -decode} errmsg set errmsg } "-decode failed: can't reversemap charset SCRIBBLE" test mime-3.13 {Parse a MIME message with a charset encoded body in an unrecognised charset but don't use -decode so we get it back raw} { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=SCRIBBLE Content-Transfer-Encoding: quoted-printable This is a message in the scribble charset that tcl does not recognise.} set tok [mime::initialize -string $msg] mime::getbody $tok } "This is a message in the scribble charset that tcl does not recognise." test mime-4.1 {Test qp_encode with a > 76 character string containing special chars.} { set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\"" mime::qp_encode $str1 } "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22" test mime-4.2 {Check that encode/decode yields original string} { set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\" " set enc [mime::qp_encode $str1] set dec [mime::qp_decode $enc] string equal $dec $str1 } {1} test mime-4.3 {mime::decode data that might come from an MUA} { set enc "I'm the =22 message =\nwith some new lines= \n but with some extra space, too. " mime::qp_decode $enc } "I'm the \" message with some new lines but with some extra space, too." test mime-4.4 {Test qp_encode with non-US_ASCCI characters.} { set str1 "Test de caract�res accentu�s : � � � � et quelques contr�les \"\[|\]()\"" mime::qp_encode $str1 } "Test de caract=E8res accentu=E9s : =E2 =EE =E9 =E7 et quelques contr=F4le=\ns =22=5B=7C=5D()=22" test mime-4.5 {Test qp_encode with softbreak} { set str1 [string repeat abc 40] mime::qp_encode $str1 } "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabca= bcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" test mime-4.6 {Test qp_encode with softbreak} { set str1 [string repeat abc 40] mime::qp_encode $str1 0 1 } [string repeat abc 40] test mime-5.1 {Test word_encode with quoted-printable method} { mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�" } "=?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?=" test mime-5.2 {Test word_encode with base64 method} { mime::word_encode iso8859-1 base64 "Test de contr�le effectu�" } "=?ISO-8859-1?B?VGVzdCBkZSBjb250cvRsZSBlZmZlY3R16Q==?=" test mime-5.3 {Test encode+decode with quoted-printable method} { set enc [mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�"] mime::word_decode $enc } {iso8859-1 quoted-printable {Test de contr�le effectu�}} test mime-5.4 {Test encode+decode with base64 method} { set enc [mime::word_encode iso8859-1 base64 "Test de contr�le effectu�"] mime::word_decode $enc } {iso8859-1 base64 {Test de contr�le effectu�}} test mime-5.5 {Test decode with lowercase quoted-printable method} { mime::word_decode "=?ISO-8859-1?q?Test_lowercase_q?=" } {iso8859-1 quoted-printable {Test lowercase q}} test mime-5.6 {Test decode with lowercase base64 method} { mime::word_decode "=?ISO-8859-1?b?VGVzdCBsb3dlcmNhc2UgYg==?=" } {iso8859-1 base64 {Test lowercase b}} test mime-5.7 {Test word_encode with quoted-printable method across encoded word boundaries} { mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�" -maxlength 31 } "=?ISO-8859-1?Q?Test_de_contr?= =?ISO-8859-1?Q?=F4le_effectu?= =?ISO-8859-1?Q?=E9?=" test mime-5.8 {Test word_encode with quoted-printable method across encoded word boundaries} { mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�" -maxlength 32 } "=?ISO-8859-1?Q?Test_de_contr?= =?ISO-8859-1?Q?=F4le_effectu?= =?ISO-8859-1?Q?=E9?=" test mime-5.9 {Test word_encode with quoted-printable method and multibyte character} { mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" } "=?EUC-JP?Q?Following_me_is_a_multibyte_character_=A4=CF?=" set n 10 while {$n < 14} { test mime-5.$n {Test word_encode with quoted-printable method and multibyte character across encoded word boundary} { mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" -maxlength [expr 42 + $n] } "=?EUC-JP?Q?Following_me_is_a_multibyte_character_?= =?EUC-JP?Q?=A4=CF?=" incr n } test mime-5.14 {Test word_encode with quoted-printable method and multibyte character (triple)} { mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?=" set n 15 while {$n < 23} { test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} { mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n] } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_?= =?UTF-8?Q?=E3=81=AF?=" incr n } while {$n < 25} { test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} { mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n] } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?=" incr n } while {$n < 29} { test mime-5.$n {Test word_encode with base64 method across encoded word boundaries} { mime::word_encode euc-jp base64 "There is a multibyte character \xA4\xCF" -maxlength [expr 28 + $n] } "=?EUC-JP?B?VGhlcmUgaXMgYSBtdWx0aWJ5dGUgY2hhcmFjdGVy?= =?EUC-JP?B?IKTP?=" incr n } while {$n < 33} { test mime-5.$n {Test word_encode with base64 method and triple byte character across encoded word boundary} { mime::word_encode utf-8 base64 "Here is a multibyte character \xE3\x81\xAF" -maxlength [expr 23 + $n] } "=?UTF-8?B?SGVyZSBpcyBhIG11bHRpYnl0ZSBjaGFyYWN0ZXIg?= =?UTF-8?B?44Gv?=" incr n } test mime-5.33 {Test word_encode with quoted-printable method and -maxlength set to same length as will the result} { mime::word_encode iso8859-1 quoted-printable "123" -maxlength 20 } "=?ISO-8859-1?Q?123?=" test mime-5.34 {Test word_encode with base64 method and -maxlength set to same length as will the result} { mime::word_encode iso8859-1 base64 "123" -maxlength 21 } "=?ISO-8859-1?B?MTIz?=" test mime-5.35 {Test word_encode with quoted-printable method and non charset encoded string} { mime::word_encode utf-8 quoted-printable "\u306F" -charset_encoded 0 } "=?UTF-8?Q?=E3=81=AF?=" test mime-5.36 {Test word_encode with base64 method and non charset encoded string} { mime::word_encode utf-8 base64 "\u306F" -charset_encoded 0 } "=?UTF-8?B?44Gv?=" test mime-5.36 {Test word_encode with base64 method and one byte} { mime::word_encode iso8859-1 base64 "a" } "=?ISO-8859-1?B?YQ==?=" test mime-5.37 {Test word_encode with base64 method and two bytes} { mime::word_encode euc-jp base64 "\xA4\xCF" } "=?EUC-JP?B?pM8=?=" test mime-5.38 {Test word_encode with unknown charset} { catch {mime::word_encode scribble quoted-printable "scribble is an unknown charset"} errmsg set errmsg } "unknown charset 'scribble'" test mime-5.39 {Test word_encode with invalid charset} { catch {mime::word_encode unicode quoted-printable "unicode is not a valid charset"} errmsg set errmsg } "invalid charset 'unicode'" test mime-5.40 {Test word_encode with invalid method} { catch {mime::word_encode iso8859-1 tea-leaf "tea-leaf is not a valid method"} errmsg set errmsg } "unknown method 'tea-leaf', must be base64 or quoted-printable" test mime-5.41 {Test word_encode with maxlength to short for method quoted-printable} { catch {mime::word_encode iso8859-1 quoted-printable "1" -maxlength 17} errmsg set errmsg } "maxlength 17 too short for chosen charset and encoding" test mime-5.42 {Test word_encode with maxlength on the limit for quoted_printable and an unquoted character} { catch {mime::word_encode iso8859-1 quoted-printable "_" -maxlength 18} errmsg set errmsg } "=?ISO-8859-1?Q?_?=" test mime-5.43 {Test word_encode with maxlength to short for method quoted_printable and a character to be quoted} { catch {mime::word_encode iso8859-1 quoted-printable "=" -maxlength 18} errmsg set errmsg } "maxlength 18 too short for chosen charset and encoding" test mime-5.44 {Test word_encode with maxlength to short for method quoted-printable and multibyte character} { catch {mime::word_encode euc-jp quoted-printable "\xA4\xCF" -maxlength 17} errmsg set errmsg } "maxlength 17 too short for chosen charset and encoding" test mime-5.45 {Test word_encode with maxlength to short for method base64} { catch {mime::word_encode iso8859-1 base64 "1" -maxlength 20} errmsg set errmsg } "maxlength 20 too short for chosen charset and encoding" test mime-6.1 {Test field_decode (from RFC 2047, part 8)} { mime::field_decode {=?US-ASCII?Q?Keith_Moore?= <[email protected]>} } {Keith Moore <[email protected]>} test mime-6.2 {Test field_decode (from RFC 2047, part 8)} { mime::field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <[email protected]>} } {Patrik F�ltstr�m <[email protected]>} test mime-6.3 {Test field_decode (from RFC 2047, part 8)} { mime::field_decode {=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=} } {If you can read this you understand the example.} foreach {n encoded expected} { 4 "(=?ISO-8859-1?Q?a?=)" "(a)" 5 "(=?ISO-8859-1?Q?a?= b)" "(a b)" 6 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" "(ab)" 7 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" "(ab)" 8 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" "(ab)" 9 "(=?ISO-8859-1?Q?a_b?=)" "(a b)" 10 "(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)" "(a b)" 11 "(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)" "(ax b)" 12 "a b c" "a b c" 13 "" "" } { test mime-6.$n {Test field_decode (from RFC 2047, part 8)} { mime::field_decode $encoded } $expected ; # {} } foreach {bug n encoded expected} { 764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(H�rz)" } { test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" { mime::field_decode $encoded } $expected ; # {} } test mime-8.1 {Test reversemapencoding+mapencoding with preferred name} { set charset [mime::reversemapencoding "US-ASCII"] mime::mapencoding $charset } {US-ASCII} test mime-8.2 {Test reversemapencoding+mapencoding with alias} { set charset [mime::reversemapencoding "UTF8"] mime::mapencoding $charset } {UTF-8} test mime-9.0 {Test chunk handling of copymessage and helpers} { set in [makeFile [set data [string repeat [string repeat "123456789 " 10]\n 350]] input.txt] set mi [makeFile {} mime.txt] set token [mime::initialize -canonical text/plain -file $in] set f [open $mi w] fconfigure $f -translation binary mime::copymessage $token $f close $f set token [mime::initialize -file $mi] set newdata [mime::getbody $token] set res [string compare $data $newdata] removeFile input.txt removeFile mime.txt unset data newdata token f in mi set res } 0 set ::env(TZ) "UTC0" set epoch [clock scan 2000-01-01] foreach {n stamp date} { 1 86340 {Sat, 01 Jan 2000 23:59:00 +0000} 2 5176620 {Tue, 29 Feb 2000 21:57:00 +0000} 3 31610520 {Sun, 31 Dec 2000 20:42:00 +0000} 4 31708740 {Mon, 01 Jan 2001 23:59:00 +0000} 5 68248620 {Thu, 28 Feb 2002 21:57:00 +0000} 6 126218520 {Wed, 31 Dec 2003 20:42:00 +0000} } { test mime-10.$n "Test formatting dates (RFC 822)" { # To verify that clock scan gets the expected value. set stamp_test [expr {[mime::parsedatetime $date clock] - $epoch}] # Parse and re-format should get us the original. set parsed_test [mime::parsedatetime $date proper] list $stamp_test $parsed_test } [list $stamp $date] } test mime-11.0 {Bug 1825092} { set in [makeFile {From [email protected] Sat Oct 20 17:58:49 2007 Return-Path: <[email protected]> Message-ID: <[email protected]> From: Somwhere <[email protected]> MIME-Version: 1.0 To: Here <[email protected]> Subject: test Content-Type: multipart/mixed; boundary="------------090305080603000703000106" This is a multi-part message in MIME format. --------------090305080603000703000106 Content-Type: text/plain; charset=ISO-8859-15 Content-Transfer-Encoding: 8bit XXX --------------090305080603000703000106 Content-Disposition: attachment; filename="a0036.dss" Content-Transfer-Encoding: base64 Content-Type: application/octet-stream; name="a0036.dss" BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ --------------090305080603000703000106-- } mail_part] set token [mime::initialize -file $in] set allparts [mime::getproperty $token parts] set attachment [lindex $allparts 1] set out [makeFile {} mail_att] set ofh [open $out w] fconfigure $ofh -translation binary mime::copymessage $attachment $ofh close $ofh set data [viewFile $out] file delete $in $out set data } {MIME-Version: 1.0 Content-Disposition: attachment; filename="a0036.dss" Content-Transfer-Encoding: base64 Content-Type: application/octet-stream; name="a0036.dss" BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ} # ------------------------------------------------------------------------- test mime-12.0 {Bug 3483716} { set token [mime::initialize -string {Content-Type: message/delivery-status; name="deliverystatus.txt" Content-Disposition: attachment; filename="deliverystatus.txt"; size=138; creation-date="Thu, 02 Feb 2012 13:50:05 GMT"; modification-date="Thu, 02 Feb 2012 13:50:05 GMT" Content-Description: deliverystatus.txt Content-Transfer-Encoding: base64 T3JpZ2luYWwtUmVjaXBpZW50OiA8L2ZheD1ibHViYkBndW1taS5ib290PgpBY3Rpb246IGZhaWxl ZApEaWFnbm9zdGljLUNvZGU6IHNtdHA7IDU1MCAjNS4xLjAgQWRkcmVzcyByZWplY3RlZC4KUmVt b3RlLU1UQTogNTMuMjQuMjgyLjE1MA== }] set parts [mime::getproperty $token parts] mime::getheader [lindex $parts end] Remote-MTA } 53.24.282.150 # ------------------------------------------------------------------------- testsuiteCleanup return |
Changes to modules/mime/mime.man.
︙ | ︙ | |||
13 14 15 16 17 18 19 20 | [keywords {rfc 821}] [keywords {rfc 822}] [keywords {rfc 2045}] [keywords {rfc 2046}] [keywords {rfc 2049}] [keywords smtp] [copyright {1999-2000 Marshall T. Rose}] [moddesc {Mime}] | > | | < | > > | > > | > > | > | | > > > > | < > | < | > > | > | | > > > | > > < > | > | > > | > | > | | | > > | > | < < > > > > > > > | | < < > > | | > | > | > | > | | < < > | | > | > > | > > > > | | > | > > < | | > > | < > | > | > > > > > | > > | > > > > > | | > > | | > > | > | > | > | | | > > | | | > > | | | < < < < | < < < | < < < | < | < < < < < < < < < | < < | < < > | < < | < < < < | < < < < < < | < < < < < | < < < < | < < < < < | < | < < < < | < | < < | < < < | < | < < < < | < | < | < | | < < | < < | < | < < < < < < < < < < | | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | [keywords {rfc 821}] [keywords {rfc 822}] [keywords {rfc 2045}] [keywords {rfc 2046}] [keywords {rfc 2049}] [keywords smtp] [copyright {1999-2000 Marshall T. Rose}] [copyright {2018 Poor Yorick}] [moddesc {Mime}] [titledesc {Manipulation of Internet messages}] [category {Text processing}] [require Tcl 8.5] [require mime [opt [vset VERSION]]] [description] [para] Provides commands to create and manipulate Internet messages. [list_begin definitions] [call [cmd ::mime::.new] [arg name] [opt [arg options]]] Parses a message, creates an routine named [arg name] as a handle for the message, and returns the name of the new routine. If [arg name] is the empty string, a name is automatically generated. One and only one of [ option -chan ], [ option -file ], or [ option -string ] must be provided as the source of the input. Optional arguments are processed such that later arguments override earlier arguments. For example, provide [option -addcontentid] [const 1] after [option "-spec [const http]"] has disabled that option. The optional arguments are [list_begin definitions] [def "[option -addcontentid] [arg boolean]"] Indicates whether a [const Content-ID] header field should be added to the message. By default, this header is added to non-canonical messages. [def "[option -addmimeversion] [arg boolean]"] Indicates whether a [const MIME-Version] header should be added to non-canonical messages. By default, this header is added to non-canonical messages. [def "[option -canonical] [arg type/subtype]"] The input message is the body only and is in the format specified by the provided [ arg type/subtype ], and therefore should not be parsed. [def "[option -chan] [arg channel]"] The name of an ensemble command providing the standard channel commands. [def "[option -encoding] [arg encoding]"] sets the [const Content-Transfer-Encoding]. [def "[option -file] [arg string]"] The file providing the input message. [def "[option -headers] [arg headers]"] [arg headers] is a multidict of headers. [def "[option -spec] [arg spec]"] [arg spec] is one of [const mime] (the default) or [const http], indicating what specification to conform to. For [const mime], the default [const Content-Type] is [const text/plain] and the character set is assumed to be [const US-ASCII]. For [const http], the default [const Content-Type] is [const text/html], the [const charset] is [const utf-8], and [const MIME-Version] and [const Content-ID] headers are by default not automatically added. [def "[option -params] [arg params]"] [arg params] is a multidict (a dictionary where the keys may not be unique) of parameters for the [ const Content-Type ] header. [def "[option -parts] [arg parts]"] [arg parts] is list of tokens for messages that comprise a [ const multipart/mixed ] message body. [def "[option -string] [arg string]"] The string providing the input message. [list_end] [call [arg message] [method body] [opt [option -decode]] [opt "[option -blocksize] [arg octets]"]"] Sets to [const 0] the cursor for the channel holding the body of the message and returns the name of a channel command for that channel. [para] If [option -blocksize] is provided, returns a command that itself returns up to the next [arg octets] of the message each time it's called, and returns a code of [const break] when finished, deleting itself as well. If [arg octets] is the empty string, a default value is used. [para] [option -decode] converts the message body from the character set it is encoded in. [call [arg message] [method {cookie delete}] [arg args]] Deletes the specifed cookie. [arg args] is the same as for [method {cookie set}], except that [arg -value] is not needed and [arg -expires] is ignored. [call [arg message] [method {cookie set}] [arg name] [arg value] [arg args]] Sets a cookie header. [arg args] is a dictionary options: [list_begin definitions] [def "[option expires] [arg date]"] [def "[option path] [arg {path restriction}]"] [def "[option domain] [arg {domain restriction}]"] [def "[option httponly] [arg boolean]"] [list_end] [call [arg message] [method .destroy] [opt "[option -subordinates] [const all] | [const dynamic] | [const none]"]] Destroys the message and returns the empty string. [para] [option -subordinates] specifies which messages comprising the body should also be destroyed. The default value of [const dynamic] indicates all component messages that were created while parsing a message. [const all] indicates all component messages. [const none] indicates that no component messages should be destroyed. [call [arg message] [method header] [method serialize] [arg value] [arg parameters]] Returns the the serialization of a header. [call [arg message] [method header] [method get] [opt "[arg key] | [option -names]"]] Returns the header of a message as a multidict where each value is a list containing the header value and a dictionary of parameters for that header. [para] If [arg name] is provided, returns the value and parameters of the last entry matching that name, without regard to case. [para] If [option -names] is provided, returns a list of all header names. [call [arg message] [method header] [method set] [arg {name value}] [ \ opt "[arg parameters] [opt "[option -mode] [const write] | [\ const append] | [const delete]"]"]] If [option -names] is provided, a list of all keys is returned. [arg parameters] is a dictionary of parameters for the header. If parameters contains an odd number of items, the last item is a list of flag parameters. [para] The value for [option -mode] is one of: [list_begin definitions] [def [const write]] The [arg key]/[arg value] is either created or overwritten (the default). [def [const append]] Appends a new [arg key]/[arg value]. [def [const delete]] Removes all values associated with the key. [arg value] is ignored. [list_end] [call [arg message] [method property] [opt "[arg name] | [option -names]"]] Returns a dictionary of message properties. If [arg name] is provided, only the corresponding value is returned. If [option -names] is provided, a list of all property names is returned. [para] properties: [list_begin definitions] [def [const content]] The type/subtype of the content [def [const encoding]] The "Content-Transfer-Encoding" [def [const params]] A list of "Content-Type" parameters [def [const parts]] A list of tokens for messages that comprise a multipart body. Only exists if there are any such messages. [def [const size]] The approximate size of the unencoded content. [list_end] [call [arg message] [method serialize] [opt [option -level]] [ opt "[option -chan] [arg channel]"]] Returns the serialization of the message. If [option -chan] is provided, writes the serialization to [arg channel] and returns the empty string. [option -level], if provided, indicates the level of the part in the message hierarchy. The [const MIME-Version] header is only included at level [const 0]. [call [cmd ::mime::datetime] ([arg time] | [option -now]) [arg property]] Returns the [arg property] of [arg time], which is an 822-style date-time value. [para] Available properties and their ranges are: [list_begin definitions] [def [const hour]] 0 .. 23 |
︙ | ︙ | |||
363 364 365 366 367 368 369 370 371 372 | 1900 ... [def [const zone]] -720 .. 720 (minutes east of GMT) [list_end] [call [cmd ::mime::mapencoding] [arg encoding_name]] | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > < < < < < < < < < < < < < < < < < < < < < < | 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | 1900 ... [def [const zone]] -720 .. 720 (minutes east of GMT) [list_end] [call [cmd ::mime::parseaddress] [arg addresses]] Returns a list describing the comma-separated 822-style [arg addresses]. [para] Each dictionary contains the following keys, whose values may be the empty string: [list_begin definitions] [def [const address]] local@domain [def [const comment]] 822-style comment [def [const domain]] the domain part (rhs) [def [const error]] non-empty on a parse error [def [const group]] this address begins a group [def [const friendly]] user-friendly rendering [def [const local]] the local part (lhs) [def [const memberP]] this address belongs to a group [def [const phrase]] the phrase part [def [const proper]] 822-style address specification [def [const route]] 822-style route specification (obsolete) [list_end] [call [cmd ::mime::mapencoding] [arg encoding_name]] Maps Tcl encodings onto the proper names for their MIME charset type. This is only done for encodings whose charset types were known. The remaining encodings return "" for now. [call [cmd ::mime::reversemapencoding] [arg charset_type]] Maps MIME charset types onto tcl encoding names. Those that are unknown return "". [list_end] [vset CATEGORY mime] [include ../common-text/feedback.inc] [manpage_end] |
Changes to modules/mime/mime.tcl.
︙ | ︙ | |||
17 18 19 20 21 22 23 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's # unpublished package of 1999. # # new string features and inline scan are used, requiring 8.3. | > > > | | > > > > > > > | 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 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's # unpublished package of 1999. # # new string features and inline scan are used, requiring 8.3. # Fix for 00d04c4f12l, base64 transchan over a refchan: segmentation fault, # requires 8.6.9 package require Tcl 8.6.9 package require {mime qp} package require namespacex package require tcl::chan::cat package require tcl::chan::memchan package require tcl::chan::string package require {chan base} package require {chan getslimit} package require sha256 package provide mime 1.7.0 if {[catch {package require Trf 2.0}]} { # Fall-back to tcl-based procedures of base64 and quoted-printable # encoders ## # Warning! |
︙ | ︙ | |||
71 72 73 74 75 76 77 | unset ::major } # # state variables: # # canonicalP: input is in its canonical form | < < | < < | < < < < < < > | > < < < < < < < < < < < < < < | 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 | unset ::major } # # state variables: # # canonicalP: input is in its canonical form # encoding: transfer encoding # version: MIME-version # header: dictionary (keys are lower-case) # value: either "chan" or "parts" # # file: input file # fd: cached file-descriptor, typically for root # root: token for top-level part, for (distant) subordinates # count: length in octets of (encoded) content # # parts: list of bodies (tokens) namespace eval ::mime { variable mime array set mime {uid 0} # RFC 822 lexemes variable addrtokenL lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\ variable addrlexemeL { LX_SEMICOLON LX_COMMA LX_LBRACKET LX_RBRACKET LX_COLON LX_DOT LX_LPAREN LX_RPAREN LX_ATSIGN LX_QUOTE LX_LSQUARE LX_RSQUARE LX_QUOTE } variable encList { ascii US-ASCII big5 Big5 cp1250 Windows-1250 cp1251 Windows-1251 cp1252 Windows-1252 cp1253 Windows-1253 |
︙ | ︙ | |||
333 334 335 336 337 338 339 | ksc5601 KSC5601 ksc5601 korean shiftjis MS_Kanji utf-8 UTF8 } namespace export {*}{ | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | < < | | < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | | | | | | | < < | < > < | | 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | ksc5601 KSC5601 ksc5601 korean shiftjis MS_Kanji utf-8 UTF8 } namespace export {*}{ .destroy .new body cookie datetime field_decode header mapencoding qp parseaddress property reversemapencoding serialize setheader uniqueID word_decode word_encode } } proc ::mime::addchan {token chan} { variable channels upvar 0 $token state upvar 0 state(fd) fd if {[info exists fd]} { error [list {a channel is already present}] } if {[$chan configure -encoding] ne {binary}} { $chan configure -translation auto } set fd $chan incr channels($fd) return } # ::mime::addr_next -- # # Locate the next address in a mime token. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_next token { # FRINK: nocheck upvar 0 $token state set nocomplain [package vsatisfies [package provide Tcl] 8.4] foreach prop {comment domain error group local memberP phrase route} { if {$nocomplain} { unset -nocomplain state($prop) } else { catch {unset state($prop)} } } switch [set code [catch {mime::addr_specification $token} result copts]] { 0 { if {!$result} { return 0 } switch $state(lastC) { LX_COMMA - LX_END { } default { # catch trailing comments... set lookahead $state(input) parselexeme $token set state(input) $lookahead } } } 7 { set state(error) $result while 1 { switch $state(lastC) { LX_COMMA - LX_END { break } default { parselexeme $token } } } } default { return -options $copts $result } } foreach prop {comment domain error group local memberP phrase route} { if {![info exists state($prop)]} { set state($prop) {} } } return 1 } # ::mime::addr_specification -- # # Uses lookahead parsing to determine whether there is another # valid e-mail address or not. Throws errors if unrecognized # or invalid e-mail address syntax is used. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_specification {token} { # FRINK: nocheck upvar 0 $token state set lookahead $state(input) switch [parselexeme $token] { LX_ATOM - LX_QSTRING { set state(phrase) $state(buffer) } LX_SEMICOLON { |
︙ | ︙ | |||
2808 2809 2810 2811 2812 2813 2814 | default { return -code 7 [ format "unexpected character at beginning (found %s)" \ $state(buffer)] } } | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | default { return -code 7 [ format "unexpected character at beginning (found %s)" \ $state(buffer)] } } switch [parselexeme $token] { LX_ATOM - LX_QSTRING { append state(phrase) " " $state(buffer) return [addr_phrase $token] } |
︙ | ︙ | |||
2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 | return -code 7 [ format "expecting mailbox (found %s)" $state(buffer)] } } return 1 } # ::mime::addr_routeaddr -- # # Parses the domain portion of an e-mail address. Finds the '@' # sign and then calls mime::addr_route to verify the domain. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_routeaddr {token {checkP 1}} { # FRINK: nocheck | > < | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 | return -code 7 [ format "expecting mailbox (found %s)" $state(buffer)] } } return 1 } # ::mime::addr_routeaddr -- # # Parses the domain portion of an e-mail address. Finds the '@' # sign and then calls mime::addr_route to verify the domain. # # Arguments: # token The MIME token to work from. # # Results: # Returns 1 if there is another address, and 0 if there is not. proc ::mime::addr_routeaddr {token {checkP 1}} { # FRINK: nocheck upvar 0 $token state set lookahead $state(input) if {[parselexeme $token] eq "LX_ATSIGN"} { #TODO: this path is not covered by tests mime::addr_route $token } else { set state(input) $lookahead } mime::addr_local $token switch $state(lastC) { LX_ATSIGN { mime::addr_domain $token } LX_SEMICOLON - LX_RBRACKET |
︙ | ︙ | |||
2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 | if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} { return -code 7 [ format "expecting right-bracket (found %s)" $state(buffer)] } return 1 } # ::mime::addr_route -- # # Attempts to parse the portion of the e-mail address after the @. # Tries to verify that the domain definition has a valid form. # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_route {token} { # FRINK: nocheck | > < | | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 | if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} { return -code 7 [ format "expecting right-bracket (found %s)" $state(buffer)] } return 1 } # ::mime::addr_route -- # # Attempts to parse the portion of the e-mail address after the @. # Tries to verify that the domain definition has a valid form. # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_route {token} { # FRINK: nocheck upvar 0 $token state set state(route) @ while 1 { switch [parselexeme $token] { LX_ATOM - LX_DLITERAL { append state(route) $state(buffer) } default { return -code 7 \ [format "expecting sub-route in route-part (found %s)" \ $state(buffer)] } } switch [parselexeme $token] { LX_COMMA { append state(route) $state(buffer) while 1 { switch [parselexeme $token] { LX_COMMA { } LX_ATSIGN { append state(route) $state(buffer) break } |
︙ | ︙ | |||
2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 | return -code 7 [ format "expecting colon to terminate route (found %s)" \ $state(buffer)] } } } } # ::mime::addr_domain -- # # Attempts to parse the portion of the e-mail address after the @. # Tries to verify that the domain definition has a valid form. # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. | > | < | | > < | | > < | | | > < | > < | > | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 | return -code 7 [ format "expecting colon to terminate route (found %s)" \ $state(buffer)] } } } } # ::mime::addr_domain -- # # Attempts to parse the portion of the e-mail address after the @. # Tries to verify that the domain definition has a valid form. # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_domain token { # FRINK: nocheck upvar 0 $token state while 1 { switch [parselexeme $token] { LX_ATOM - LX_DLITERAL { append state(domain) $state(buffer) } default { return -code 7 [ format "expecting sub-domain in domain-part (found %s)" \ $state(buffer)] } } switch [parselexeme $token] { LX_DOT { append state(domain) $state(buffer) } LX_ATSIGN { append state(local) % $state(domain) unset state(domain) } default { return } } } } # ::mime::addr_local -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_local {token} { # FRINK: nocheck upvar 0 $token state set state(memberP) $state(glevel) while 1 { switch [parselexeme $token] { LX_ATOM - LX_QSTRING { append state(local) $state(buffer) } default { return -code 7 \ [format "expecting mailbox in local-part (found %s)" \ $state(buffer)] } } switch [parselexeme $token] { LX_DOT { append state(local) $state(buffer) } default { return } } } } # ::mime::addr_phrase -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_phrase {token} { # FRINK: nocheck upvar 0 $token state while 1 { switch [parselexeme $token] { LX_ATOM - LX_QSTRING { append state(phrase) " " $state(buffer) } default { break } } } switch $state(lastC) { LX_LBRACKET { return [addr_routeaddr $token] } LX_COLON { return [addr_group $token] } LX_DOT { append state(phrase) $state(buffer) return [addr_phrase $token] } default { return -code 7 [ format "found phrase instead of mailbox (%s%s)" \ $state(phrase) $state(buffer)] } } } # ::mime::addr_group -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_group {token} { # FRINK: nocheck upvar 0 $token state if {[incr state(glevel)] > 1} { return -code 7 [ format "nested groups not allowed (found %s)" $state(phrase)] } set state(group) $state(phrase) unset state(phrase) set lookahead $state(input) while 1 { switch [parselexeme $token] { LX_SEMICOLON - LX_END { set state(glevel) 0 return 1 } LX_COMMA { } default { set state(input) $lookahead return [addr_specification $token] } } } } # ::mime::addr_end -- # # # Arguments: # token The MIME token to work from. # # Results: # Returns nothing if successful, and throws an error if invalid # syntax is found. proc ::mime::addr_end {token} { # FRINK: nocheck upvar 0 $token state switch $state(lastC) { LX_SEMICOLON { if {[incr state(glevel) -1] < 0} { return -code 7 "extraneous semi-colon" } } LX_COMMA - LX_END { } default { return -code 7 [ format "junk after local@domain (found %s)" $state(buffer)] } } } # ::mime::addr_x400 -- # # # Arguments: # token The MIME token to work from. # |
︙ | ︙ | |||
3245 3246 3247 3248 3249 3250 3251 | if {[set x [string first / $mbox]] > 0} { set mbox [string range $mbox 0 [expr {$x - 1}]] } return [string trim $mbox \"] } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 | if {[set x [string first / $mbox]] > 0} { set mbox [string range $mbox 0 [expr {$x - 1}]] } return [string trim $mbox \"] } proc ::mime::checkinputs {} { upvar 1 inputs inputs if {[incr inputs] > 1} { error [list {more than one input source provided}] } } proc ::mime::body_decoded _ { set token [$_ token] upvar 0 $token state upvar 0 state(bodychandecoded) bodychandecoded $_ parsepart if {[info exists state(parts)]} { error [list {not a leaf part} $token] } if {$state(canonicalP)} { $state(fd) seek 0 return $state(fd) } else { if {![info exists bodychandecoded]} { set bodychandecoded [::tcllib::chan::base .new [ info cmdcount]_bodydecoded [file tempfile]] $bodychandecoded configure -translation binary $state(bodychan) seek 0 $state(bodychan) copy [$bodychandecoded $ chan] $bodychandecoded seek 0 $state(bodychan) seek 0 setencoding $token $bodychandecoded setcharset $_ $bodychandecoded } $bodychandecoded seek 0 return $bodychandecoded } } proc ::mime::body_raw _ { set token [$_ token] upvar 0 $token state $_ parsepart if {[info exists state(parts)]} { error [list {not a leaf part} $token] } if {$state(canonicalP)} { $state(fd) seek 0 return $state(fd) } else { $state(bodychan) seek 0 return $state(bodychan) } } namespace eval ::mime::body { namespace ensemble create -parameters token namespace export * namespacex import [namespace parent] body_decoded decoded body_raw raw } proc ::mime::contenttype _ { set token [$_ token] upvar 0 $token state try { $_ header get content-type } on error {cres copts} { # rfc 2045 5.2 try { if {header::exists $token MIME-Version} { return text/plain } else { switch $state(spec) { cgi - http { return {text/html {charset UTF-8}} } mime { # do not specify US-ASCII here as it is the default return text/plain } } } } on error {} { return application/octet-stream } } } proc ::mime::cookie_delete {_ name args} { # this -expires overrides any that might be in $args $_ cookie set value {} {*}$args expires [ format 0 -timezone :UTC -format {%a, %d %b %Y %H:%M:%S %z}] return } # ::mime::cookie_set # # Set a return cookie. You must call this before you call # ncgi::header or ncgi::redirect # # Arguments: # args Name value pairs, where the names are: # name Cookie name # value Cookie value # ?path? Path restriction # ?domain? domain restriction # ?expires? Time restriction # ?httponly? boolean, default true # # Side Effects: # Formats and stores the Set-Cookie header for the reply. proc ::mime::cookie_set {_ name value args} { dict size $args foreach {key val} $args { switch $key { domain - expires - httponly - path { set $key $val } default { error [list {wrong # args} {should be} \ [list name value ?path path? ?domain domain? \ ?expires date? ?httponly boolean?]] } } } set line $name=$value set params {} set flags {} foreach extra {path domain} { if {[info exists $extra]} { lappend params $extra [set $extra] } } if {[info exists expires]} { switch -glob $expires { *GMT { # do nothing } default { set expires [clock format [datetimescan $expires] \ -format {%A, %d-%b-%Y %H:%M:%S GMT} -gmt 1] } } lappend params expires $expires } if {[info exists secure]} { lappend flags secure } if {![info exists httponly] || $httponly} { lappend flags HttpOnly } if {[llength $flags]} { lappend params $flags } $_ header set Set-Cookie $line $params return } # ::mime::datetime -- # # Fortunately the clock command in the Tcl 8.x core does all the heavy # lifting for us (except for timezone calculations). # # mime::datetime takes a string containing an 822-style date-time # specification and returns the specified property. # # The list of properties and their ranges are: # # property range # ======== ===== # clock raw result of "clock scan" |
︙ | ︙ | |||
3297 3298 3299 3300 3301 3302 3303 | variable MONTHS_SHORT [list {} \ Jan Feb Mar Apr May Jun \ Jul Aug Sep Oct Nov Dec] variable MONTHS_LONG [list {} \ January February March April May June July \ August Sepember October November December] } | | | < < < < < < < < < < < < < | | | 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 | variable MONTHS_SHORT [list {} \ Jan Feb Mar Apr May Jun \ Jul Aug Sep Oct Nov Dec] variable MONTHS_LONG [list {} \ January February March April May June July \ August Sepember October November December] } proc ::mime::datetime {value property} { if {$value eq {-now}} { set clock [clock seconds] } else { set clock [datetimescan $value] } switch $property { clock { return $clock } hour { set value [clock format $clock -format %H] } |
︙ | ︙ | |||
3412 3413 3414 3415 3416 3417 3418 | zone { set value [string trim [string map [list \t { }] $value]] if {[set x [string last { } $value]] < 0} { return 0 } set value [string range $value [expr {$x + 1}] end] | | | 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 | zone { set value [string trim [string map [list \t { }] $value]] if {[set x [string last { } $value]] < 0} { return 0 } set value [string range $value [expr {$x + 1}] end] switch [set s [string index $value 0]] { + - - { if {$s eq "+"} { #TODO: This path is not covered by tests set s {} } set value [string trim [string range $value 1 end]] if {( |
︙ | ︙ | |||
3471 3472 3473 3474 3475 3476 3477 | if {[set value [string trimleft $value 0]] eq {}} { #TODO: this path is not covered by tests set value 0 } return $value } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < > > | | | > > > | > > > > > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 | if {[set value [string trimleft $value 0]] eq {}} { #TODO: this path is not covered by tests set value 0 } return $value } proc ::mime::datetimescan value { variable timeformats foreach format $timeformats { if {![catch {clock scan $value -format $format} cres copts]} break } return -options $copts $cres } # ::mime::encoding -- # # Determines how a token is encoded. # # Arguments: # token # The MIME token to parse. # # Results: # Returns the encoding of the message (the null string, base64, # or quoted-printable). proc ::mime::encoding _ { set token [$_ token] # FRINK: nocheck upvar 0 $token state upvar 0 state(fd) chan state(params) params if {[info exists state(encoding)]} { return $state(encoding) } lassign [$_ contenttype] content switch -glob $content { audio/* - image/* - video/* { return [set state(encoding) base64] } message/* - multipart/* { return [set state(encoding) {}] } default {# Skip} } set asciiP 1 set lineP 1 if {[info exists state(parts)]} { return [set state(encoding) {}] } if {[set current [$chan tell]] < 0} { makeseekable $token set current [$chan tell] } set chanconfig [$chan configure] try { set buf {} set dataend 0 while {[set data [$chan read 8192]] ne {} || $buf ne {}} { if {$data eq {}} { set dataend 1 } set data $buf[set buf {}]$data[set data{}] set lines [split $data \n] if {!$dataend} { set buf [lindex $lines end] set lines [lrange $lines[set lines {}] 0 end-1] } if {[llength $lines]} { if {$asciiP} { set asciiP [encodingasciiP $lines] } if {$lineP} { set lineP [encodinglineP $lines] } if {(!$asciiP) && (!$lineP)} { break } } } } finally { $chan configure {*}$chanconfig $chan seek 0 } switch -glob $content { text/* { if {!$asciiP} { #TODO: this path is not covered by tests if {[dict exists $params charset]} { set v [string tolower [dict get $params $charset]] if {($v ne {us-ascii}) \ && (![string match {iso-8859-[1-8]} $v])} { return [set state(encoding) base64] } } } if {!$lineP} { return [set state(encoding) quoted-printable] } } default { if {(!$asciiP) || (!$lineP)} { return [set state(encoding) base64] } } } return [set state(encoding) {}] } # ::mime::encodingasciiP -- # # Checks if a string is a pure ascii string, or if it has a non-standard # form. # # Arguments: # line The line to check. # # Results: # Returns 1 if \r only occurs at the end of lines, and if all # characters in the line are between the ASCII codes of 32 and 126. proc ::mime::encodingasciiP lines { foreach line $lines { set firstr [string first \r $line]] if { $firstr > 0 && $first != [string length $line] } { return 0 } foreach c [split $line {}] { switch $c { { } - \t - \r - \n { } default { binary scan $c c c if {($c < 32) || ($c > 126)} { return 0 } } } } } return 1 } # ::mime::encodinglineP -- # # Checks if a string is a line is valid to be processed. # # Arguments: # line The line to check. # # Results: # Returns 1 the line is less than 76 characters long, the line # contains more characters than just whitespace, the line does # not start with a '.', and the line does not start with 'From '. proc ::mime::encodinglineP lines { foreach line $line { if {([string length $line] > 76) \ || ($line ne [string trimright $line]) \ || ([string first . $line] == 0) \ || ([string first {From } $line] == 0)} { return 0 } } return 1 } proc ::mime::contentid _ { set token [$_ token] upvar 0 $token state upvar 0 state(parts) parts $_ parsepart if {[info exists parts]} { foreach part $parts { upvar 0 $part childpart set created 0 if {![header::exists $part message-id]} { set created 1 header::setinternal $part Message-ID [messageid $part] } # use message-id here, not content-id, to account for header info # in the parts append ids [$part header get message-id] if {$created} { if {!$childpart(addmessageid)} { header::unset $part message-id } } } set id [::sha2::sha256 -hex $ids] } else { set chan [$_ body decoded] set config [$chan configure] if {[dict exists $config -chan]} { dict unset config -chan } try { $chan seek 0 set id [::sha2::sha256 -hex -channel [$chan configure -chan]] $chan seek 0 } finally { $chan configure {*}$config } } return $id@| } proc ::mime::dropchan token { variable channels upvar 0 $token state upvar 0 state(fd) fd if {[info exists fd]} { if {[incr channels($fd) -1] == 0} { unset channels($fd) if {$state(closechan)} { $fd close } } unset state(fd) } } # ::mime::.destroy -- # # mime::.destroy destroys a MIME part. # # If the -subordinates option is present, it specifies which # subordinates should also be destroyed. The default value is # "dynamic". # # Arguments: # token The MIME token to parse. # args Args can be optionally be of the following form: # ?-subordinates "all" | "dynamic" | "none"? # # Results: # Returns an empty string. proc ::mime::.destroy {token args} { # FRINK: nocheck upvar 0 $token state array set options [list -subordinates dynamic] array set options $args set ensemble $state(ensemble) switch $options(-subordinates) { all { #TODO: this code path is untested if {[info exists state(parts)]} { foreach part $state(parts) { $part .destroy } } } dynamic { foreach part $state(dynamic) { $part .destroy } } none { } default { error "unknown value for -subordinates $options(-subordinates)" } } dropchan $token if {$state(bodychan) ne {}} { if {[$state(bodychan) configure -chan] in [chan names]} { rename $state(bodychan) {} } } if {[info exists state(bodychandecoded)]} { rename $state(bodychandecoded) {} } foreach name [array names state] { unset state($name) } if {[namespace which $ensemble] ne {}} { rename $ensemble {} # FRINK: nocheck } unset $token } proc ::mime::messageid _ { set token [$_ token] upvar 0 $token state #set unique [uniqueID] if {![header::exists $token content-id] && $state(addcontentid)} { header::setinternal $token Content-ID [contentid $_] } set sha [::sha2::SHA256Init] foreach {key val} [lsort -stride 2 [$_ header get]] { lassign $val value params ::sha2::SHA256Update $sha $key$value foreach {pkey pval} $params { ::sha2::SHA256Update $sha $pkey$pval } } set hash [::sha2::SHA256Final $sha] binary scan $hash H* hex return $hex@| } # ::mime::mimegets -- # # like [gets] but does not run over multipart boundaries # # only needed during the parsing stage, since after that the content of each # part is in a separate file # # Arguments: # token The MIME token to parse. # # Results: # Returns the size in bytes of the MIME token. proc ::mime::mimegets {token varname} { upvar 0 $token state upvar 0 state(boundary) boundary state(eof) eof upvar 1 $varname line if {$eof} { set line {} return -1 } set res [$state(fd) gets line] if {$res == -1} { set eof 1 set line {} return -1 } else { set found [string first --$boundary $line] if {$found == 0} { if {[string first --$boundary-- $line] >= 0} { set state(sawclosing) 1 set eof 1 } set line {} return -1 } return $res } } # ::mime::getsize -- # # Determine the size (in bytes) of a MIME part/token # # Arguments: # token The MIME token to parse. # # Results: # Returns the size in bytes of the MIME token. proc ::mime::getsize _ { set token [$_ token] # FRINK: nocheck upvar 0 $token state upvar 0 state(bodychan) bodychan state(fd) inputchan $_ parsepart if {[info exists state(parts)]} { set size 0 foreach part $state(parts) { incr size [getsize $part] } } else { set size 0 if {$state(canonicalP)} { if {[set current [$inputchan tell]] < 0} { makeseekable $token } set current [$inputchan tell] $inputchan seek 0 end set size [$inputchan tell] $inputchan seek $current } else { set size $state(size) } } # no longer needed since size is calculated during parsing #if {$state(encoding) eq {base64}} { # set size [expr {($size * 3 + 2) / 4}] #} return $size } proc ::mime::getTransferEncoding _ { set token [$_ token] upvar 0 $token state # not the global [encoding] set encoding [encoding $_] # See also issues [#477088] and [#539952] switch $encoding { base64 - quoted-printable - 7bit - 8bit - binary - {} { } default { error [list {Can't handle content encoding} $encoding] } } return $encoding } namespace eval ::mime::header { variable tchar # hypen is first for inclusion in brackets variable tchar_re {-!#$%&'*+.^`|~0-9A-Za-z} variable token_re "^(\[$tchar_re]*)\\s*(?:;|$)?" variable notattchar_re "\[^[string map {* {} ' {} % {}} $tchar_re]]" # RFC 2045 lexemes variable typetokenL lappend typetokenL \; , < > : ? ( ) @ \" \[ ] = / \\ variable typelexemeL { LX_SEMICOLON LX_COMMA LX_LBRACKET LX_RBRACKET LX_COLON LX_QUESTION LX_LPAREN LX_RPAREN LX_ATSIGN LX_QUOTE LX_LSQUARE LX_RSQUARE LX_EQUALS LX_SOLIDUS LX_QUOTE } variable internal 0 } proc ::mime::header::boundary {} { return [uniqueID] } # ::mime::dunset -- # # Unset all values for $key, without "normalizing" other redundant keys proc ::mime::header::dunset {dictname key} { upvar 1 $dictname dict set dict [join [lmap {key1 val} $dict[set dict {}] { if {$key1 eq $key} continue list $key1 $val }]] } proc ::mime::header::exists {token name} { upvar 0 $token state set lname [string tolower $name] expr {[dict exists $state(headerlower) $lname] || [dict exists $state(headerinternallower) $lname] || [dict exists $state(contentidlower) $lname] || [dict exists $state(messageidlower) $lname] } } # ::mime::header get -- # # Returns the header of a message as a multidict where each value is a list # containing the header value and a dictionary parameters for that header. # If $key is provided, returns only the value and paramemters of the last # maching header, without regard for case. # # If -names is specified, a list of all header names is returned. # proc ::mime::header::get {_ {key {}}} { set token [$_ token] # FRINK: nocheck upvar 0 $token state parse $token set contentid $state(contentid) set contentidlower $state(contentidlower) set header $state(header) set headerlower $state(headerlower) set headerinternal $state(headerinternal) set headerinternallower $state(headerinternallower) set messageid $state(messageid) set messageidlower $state(messageidlower) switch $key { {} { set result [list {*}$messageid {*}$contentid {*}$headerinternal \ {*}$header] if {![dict exists $headerlower content-transfer-encoding] && !$state(canonicalP)} { set tencoding [getTransferEncoding $_] if {$tencoding ne {}} { lappend result Content-Transfer-Encoding [list $tencoding {}] } } return $result } -names { return [dict keys $header] } default { set lower [string tolower $key] switch $lower { content-id { if {![dict size $contentidlower]} { contentid $token } return [dict get $contentidlower content-id] } content-transfer-encoding { if {[dict exists $headerinternallower $lower]} { return [dict get $headerinternallower $lower] } elseif {!$state(canonicalP)} { return [list [getTransferEncoding $_] {}] } else { error [list {no such header} $key] } } message-id { if {![dict size $messageidlower]} { setinternal $token Message-ID [[namespace parent]::messageid $_] } return [dict get $messageidlower message-id] } mime-version { return [list $state(version) {}] } default { set res {} if {[dict exists $headerinternallower $lower]} { return [dict get $headerinternallower $lower] } elseif {[dict exists $headerlower $lower]} { return [dict get $headerlower $lower] } else { error [list {no such header} $key] } } } } } } proc ::mime::header::parse token { # FRINK: nocheck upvar 0 $token state upvar 0 state(fd) fd state(boundary) boundary if {$state(canonicalP) || $state(headerparsed)} { return } set state(headerparsed) 1 if {[info exists boundary]} { set gets [list [namespace parent]::mimegets $token line] } else { set gets [list $fd gets line] } set vline {} while 1 { set blankP 0 set x [{*}$gets] if {$x <= 0} { set blankP 1 } # to do 2018-11-13: probably remove this now that line translation # happens automatically, if {!$blankP && [string match *\r $line]} { set line [string range $line 0 $x-2] if {$x == 1} { set blankP 1 } } # there is a space and a tab between the brackets in next line if {!$blankP && [string match {[ ]*} $line]} { append vline { } [string trimleft $line " \t"] continue } if {$vline eq {}} { if {$blankP} { break } set vline $line continue } if { [set x [string first : $vline]] <= 0 || [set mixed [string trimright [ string range $vline 0 [expr {$x - 1}]]]] eq {} } { error [list {improper line in header} $vline] } set value [string trim [string range $vline [expr {$x + 1}] end]] switch [set lower [string tolower $mixed]] { content-disposition { set_ $token $mixed {*}[parseparts $token $value] } content-id { setinternal $token $mixed $value } content-type { if {[exists $token content-type]} { error [list {multiple Content-Type fields starting with} \ $vline] } set x [parsetype $token $value] setinternal $token Content-Type {*}$x } content-md5 { } content-transfer-encoding { if { $state(encoding) ne {} && $state(encoding) ne [string tolower $value] } { error [list [list multiple Content-Transfer-Encoding \ fields starting with] $vline] } set state(encoding) [string tolower $value] } mime-version { set state(version) $value } default { set_ $token $mixed $value -mode append } } if {$blankP} { break } set vline $line } } proc ::mime::header::parseparams token { # FRINK: nocheck upvar 0 $token state set params {} while 1 { switch [parselexeme $token] { LX_END { return [processparams $params[set params {}]] } LX_SEMICOLON { if {[dict size $params]} { continue } else { error [list {expecting attribute} not $state(buffer)] } } LX_ATOM { } default { error [list {expecting attribute} not $state(buffer)] } } set attribute [string tolower $state(buffer)] if {[parselexeme $token] ne {LX_EQUALS}} { error [list expecting = found $state(buffer)] } switch [parselexeme $token] { LX_ATOM { } LX_QSTRING { set state(buffer) [ string range $state(buffer) 1 [ expr {[string length $state(buffer)] - 2}]] set state(buffer) [unquote $state(buffer)] } default { error [list expecting value found $state(buffer)] } } dict set params $attribute $state(buffer) } } proc ::mime::header::parseparts {token value} { variable token_re upvar 0 $token state if {![regexp $token_re $value match type]} { error [list {expected disposition-type}] } variable typetokenL variable typelexemeL set value [string range $value[set value {}] [string length $match] end] set state(input) $value set state(buffer) {} set state(lastC) LX_END set state(comment) {} set state(tokenL) $typetokenL set state(lexemeL) $typelexemeL set code [catch {parseparams $token} result copts] unset {*}{ state(input) state(buffer) state(lastC) state(comment) state(tokenL) state(lexemeL) } return -options $copts [list $type $result] } # ::mime::header::parsetype -- # # Parses the string passed in and identifies the content-type and # params strings. # # Arguments: # token The MIME token to parse. # string The content-type string that should be parsed. # # Results: # Returns the content and params for the string as a two element # tcl list. proc ::mime::header::parsetype {token string} { # FRINK: nocheck upvar 0 $token state variable typetokenL variable typelexemeL set state(input) $string set state(buffer) {} set state(lastC) LX_END set state(comment) {} set state(tokenL) $typetokenL set state(lexemeL) $typelexemeL catch {parsetypeaux $token} result copts unset {*}{ state(input) state(buffer) state(lastC) state(comment) state(tokenL) state(lexemeL) } return -options $copts $result } # ::mime::header::parsetypeaux -- # # A helper function for mime::parsetype. Parses the specified # string looking for the content type and params. # # Arguments: # token The MIME token to parse. # string The content-type string that should be parsed. # # Results: # Returns the content and params for the string as a two element # tcl list. proc ::mime::header::parsetypeaux token { # FRINK: nocheck upvar 0 $token state set params {} if {[parselexeme $token] ne {LX_ATOM}} { error [list expecting type found $state(buffer)] } set type [string tolower $state(buffer)] switch [parselexeme $token] { LX_SOLIDUS { } LX_END { if {$type ne {message}} { error [list expecting type/subtype found $type] } return [list message/rfc822 {}] } default { error [list expecting / found $state(buffer)] } } if {[parselexeme $token] ne {LX_ATOM}} { error [list expecting subtype found $state(buffer)] } append type [string tolower /$state(buffer)] switch [parselexeme $token] { LX_END { } LX_SEMICOLON { set params [parseparams $token] } default { error [list expecting {; or end} found $state(buffer)] } } list $type $params } proc ::mime::header::processparams params { set info {} foreach key [lsort -dictionary [dict keys $params]] { set pvalue [dict get $params $key] # a trailing asterisk is ignored if this is not the first field in an # identically-named series # this expression can't fail regexp {^([^*]+?)(?:([*])([0-9]+))?([*])?$} $key -> name star1 counter star2 dict update info $name dict1 { if {![info exists dict1]} { set dict1 {} } dict update dict1 encoding encoding value value { if {$star1 ne {}} { if {$star2 ne {} || $counter eq {}} { if {![regexp {^([^']*)'([^']*)'(.*)$} $pvalue \ -> charset lang pvalue]} { error [list [list malformed language information in \ extended parameter name]] } if {$charset ne {}} { set encoding [reversemapencoding $charset] } } } append value $pvalue } } } set params {} dict for {key pinfo} $info[set info {}] { dict update pinfo encoding encoding value value {} if {[info exists encoding]} { set value [string map {% {\x}} $value[set value {}]] set value [subst -novariables -nocommands $value[set value {}]] set value [::encoding convertfrom $encoding $value] } dict set params $key $value } return $params } proc ::mime::header::serialize {name value params} { variable notattchar_re set lname [string tolower $name] # to do: check key for conformance # to do: properly quote/process $value for interpolation if {[regexp {[^\x21-\x39\x3b-\x7e]} $name]} { error [ list {non-printing character or colon character in header name} $name] } if {[regexp {[^\t\x20-\x7e]} $value]} { error [ list {non-printing character in header value}] } switch $lname { content-id - message-id { set value <$value> } } set res "$name: $value" if {[llength $params] % 2} { set extra [lindex $params end] set params [lreplace $params[set params {}] end end] } else { set extra {} } foreach {key value} $params { if {[regexp $notattchar_re $key]} { error [list {illegal character found in attribute name}] } set len [expr {[string length $key]} + 1 + [string length $value]] # save one byte for the folding white space continuation space # and two bytes for "; " if {$len > 73 || ![regexp {[^-!#$%&'*+,.\w`~^@{}|]+$} $value]} { # save two bytes for the quotes if {$len <= 71 && ![regexp {[^\x20-\x7e]} $value]} { set value "[string map [list \\ \\\\ \" \\\"] $value[set value {}]]" append res "\n\t; $key=$value" } else { set value [::encoding convertto utf-8 $value] regsub -all -- $notattchar_re $value {[format %%%02X [scan "\\&" %c]]} value set value [subst -novariables $value] set partnum 0 set start 0 set param $key*$partnum*=utf-8'' while {$start < [string length $value]} { # subtract one from the limit to ensure that at least one byte # is included in the part value if {[string length $param] > 72} { error [list {parameter name is too long}] } set end [expr {$start + 72 - [string length $param]}] set part [string range $value $start $end] incr start [string length $part] append res "\n\t; $param$part" set param $key*$partnum= incr partnum } } } else { append res "\n\t; $key=$value" } } foreach item $extra { append res "\n\t; $item" } return $res } # ::mime::header::set -- # # mime::header::set writes, appends to, or deletes the value associated # with a key in the header. # # The value for -mode is one of: # # write: the key/value is either created or overwritten (the # default); # # append: a new value is appended for the key (creating it as # necessary); or, # # delete: all values associated with the key are removed (the # "value" parameter is ignored). # # Regardless, mime::setheader returns the previous value associated # with the key. # # Arguments: # token The MIME token to parse. # key The name of the key whose value should be set. # value The value for the header key to be set to. # ?params? A dictionary of parameters for the header. # ?args? An optional argument of the form: # ?-mode "write" | "append" | "delete"? # # Results: # Returns previous value associated with the specified key. proc ::mime::header::set_ {token key value args} { variable internal # FRINK: nocheck upvar 0 $token state upvar 0 \ state(contentid) contentid \ state(contentidlower) contentidlower \ state(header) header \ state(headerinternal) headerinternal \ state(headerinternallower) headerinternallower \ state(headerlower) headerlower \ state(messageid) messageid \ state(messageidlower) messageidlower parse $token set params {} switch [llength $args] { 1 - 3 { set args [lassign $args[set args {}] params] } 0 - 2 { # carry on } default { error [list {wrong # args}] } } array set options [list -mode write] array set options {} dict for {opt val} $args { switch $opt { -mode { set options($opt) $val } default { error [list {unknon option} $opt] } } } set lower [string tolower $key] set result {} switch $options(-mode) { append - write { switch $lower { content-md5 - content-transfer-encoding - mime-version - content-type { if {!$internal} { switch $lower { default { if {[exists $token $lower]} { lassign [get $token $lower] values params1 if {$value ni $values} { error "key $key may not be set" } } } } } switch $lower { content-type { if {[string match multipart/* $value] && ![dict exists $params boundary] } { dict set params boundary [boundary] } } default { #carry on } } } } if {$options(-mode) eq {write}} { if {[dict exists $header $key]} { dunset header $key } if {[dict exists $headerlower $lower]} { dunset headerlower $lower } if {[dict exists headerinternal $key]} { dunset headerinternal $key } if {[dict exists $headerinternallower $lower]} { dunset headerinternallower $lower } } set newval [list $value $params] if {$internal} { switch $lower { content-id { lappend contentid $key $newval lappend contentidlower $lower $newval } message-id { lappend messageid $key $newval lappend messageidlower $lower $newval } default { lappend headerinternal $key $newval lappend headerinternallower $lower $newval } } } else { lappend header $key $newval lappend headerlower $lower $newval } } delete { dunset headerlower $lower dunset headerinternallower $lower dunset header $key dunset headerinternal $key } default { error "unknown value for -mode $options(-mode)" } } return $result } proc ::mime::header::setinternal args { variable internal 1 try { set_ {*}$args } finally { set internal 0 } } # ::mime::.new -- # # the public interface for initializeaux proc ::mime::.new args { variable mime if {[llength $args] % 2} { set args [lassign $args[set args {}] name] } elseif {[llength $args]} { error [list {wrong # args}] } else { set name {} } set mimeid [incr mime(uid)] set token [namespace current]::$mimeid if {$name eq {}} { set name $token } elseif {![string match ::* $name]} { set name [uplevel 1 {namespace current}]::$name } set cookiecmd [namespace current]::${mimeid}_cookie namespace ensemble create -command $cookiecmd -map [list \ delete [list cookie_delete $name] \ set [list cookie_set $name] ] set headercmd [namespace current]::${mimeid}_header namespace ensemble create -command $headercmd -map [list \ get [list header::get $name] \ exists [list header::exists $token] \ parse [list header::parse $token] \ set [list header::set_ $token] \ serialize header::serialize \ setinternal [list header::setinternal $token] ] namespace ensemble create -command $name -map [list \ .destroy [list .destroy $token] \ body [list body $name] \ contenttype [list contenttype $name] \ cookie [list $cookiecmd] \ datetime [list datetime $token] \ field_decode [list field_decode $token] \ header [list $headercmd] \ mapencoding [list mapencoding $token] \ qp [list qp $token] \ parseaddress [list parseaddress $token] \ parsepart [list parsepart $name] \ property [list property $name] \ reversemapencoding [list reversemapencoding $token] \ serialize [list serialize $name] \ setheader [list setheader $token] \ token [list ::lindex $token] \ uniqueID [list uniqueID $token] \ word_decode [list word_decode $token] \ word_encode [list word_encode $token] ] trace add command $name delete [list apply [list { token cookiecmd headercmd old new op} { ::mime::.destroy $token rename $cookiecmd {} rename $headercmd {} }] $token $cookiecmd $headercmd] # FRINK: nocheck upvar 0 $token state set state(ensemble) $name if {[catch {uplevel 1 [ list mime::initializeaux $name {*}$args]} result eopts]} { catch {mime::.destroy $token -subordinates dynamic} return -options $eopts $result } return $name } # ::mime::initializeaux -- # # Creates a MIME part and returns the MIME token for that part. # # Arguments: # args Args can be any one of the following: # ?-canonical type/subtype # ?-params {?key value? ...} # ?-encoding value? # ?-headers {?key value? ...} # ?-spec ?mime | cgi | http? # (-chan value | -parts {token1 ... tokenN}) # # If the -canonical option is present, then the body is in # canonical (raw) form and is found by consulting either the, # -chan, or -parts option. # # -header # a dictionary of headers # with possibliy-redundant keys # # -params # a dictionary of parameters # with possibly-redundant keys # # # Also, -encoding, if present, specifies the # "Content-Transfer-Encoding" when copying the body. # # If the -canonical option is not present, then the MIME part # contained in -chan option is parsed, # dynamically generating subordinates as appropriate. # # Results: # An initialized mime token. proc ::mime::initializeaux {_ args} { set token [$_ token] variable channels # FRINK: nocheck upvar 0 $token state upvar 0 state(canonicalP) canonicalP state(params) params \ state(relax) relax set ipnuts 0 set params {} set state(addcontentid) 1 set state(addmessageid) 1 set state(addmimeversion) 1 # contains the decoded message body set state(bodychan) {} set state(bodydecoded) 0 set state(bodyparsed) 0 set state(dynamic) {} set canonicalP 0 set state(closechan) 1 set state(contentid) {} set state(contentidlower) {} set state(encoding) {} set state(encodingdone) 0 set state(eof) 0 set state(header) {} set state(headerinternal) {} set state(headerinternallower) {} set state(headerlower) {} set state(headerparsed) 0 set state(isstring) 0 set relax [dict create finalboundary 0] set state(messageid) {} set state(messageidlower) {} set state(root) $token set state(sawclosing) 0 set state(spec) mime set state(size) 0 set state(usemem) 0 set state(version) 1.0 set state(warnings) {} set userparams 0 set argc [llength $args] for {set argx 0} {$argx < $argc} {incr argx} { set option [lindex $args $argx] if {[incr argx] >= $argc} { error "missing argument to $option" } set value [lindex $args $argx] switch $option { -addcontentid { set state(addcontentid) [expr {!!$value}] } -addmessageid { set state(addmessageid) [expr {!!$value}] } -addmimeversion { set state(addmimeversion) [expr {!!$value}] } -boundary { set state(boundary) $value } -canonical { set canonicalP 1 set type [string tolower $value] } -chan { checkinputs addchan $token [uplevel 1 [list namespace which $value]] } -close { set state(closechan) [expr {!!$value}] } -encoding { set value [string tolower $value[set value {}]] switch $value { 7bit - 8bit - binary - quoted-printable - base64 { } default { error "unknown value for -encoding $state(encoding)" } } set state(encoding) [string tolower $value] } -file { checkinputs addchan $token [tcllib::chan::base .new [ info cmdcount]_chan [open $value]] } -headers { # process headers later in order to assure that content-id and # content-type occur first if {[info exists headers]} { error [list {-headers option occurred more than once}] } if {[llength $value] % 2} { error [list -headers expects a dictionary] } set headers $value } -params { if {$userparams} { error [list {-params can only be provided once}] } set userparams 1 if {[llength $value] % 2} { error [list -params expects a dictionary] } foreach {mixed pvalue} $value { set lower [string tolower $mixed] if {[dict exists params $lower]} { error "the $mixed parameter may be specified at most once" } dict set params $lower $pvalue } } -parts { checkinputs set canonicalP 1 set state(parts) $value } -relax { relax $token $value 1 } -root { # the following are internal options set state(root) $value } -spec { switch $value { cgi - http { set state(addcontentid) 0 set state(addmimeversion) 0 set state(addmessageid) 0 set state(spec) http } mime { set state(addcontentid) 1 set state(addmimeversion) 1 set state(spec) mime } default { error [list {unknown protocol}] } } } -strict { relax $token $value [expr {!$value}] } -string { checkinputs addchan $token [tcllib::chan::base .new [ info cmdcount]_chan [::tcl::chan::string $value]] } -usemem { set state(usemem) [expr {!!$value}] } default { error [list {unknown option} $option] } } } if {![info exists inputs]} { error [list {specify exactly one of} {-chan -file -parts -string}] } if {$canonicalP} { if {![info exists type]} { set type multipart/mixed } header::setinternal $token Content-Type $type $params if {[info exists headers]} { foreach {name hvalue} $headers { set lname [string tolower $name] if {$lname eq {content-type}} { error [list {use -canonical instead of -headers} $hkey $name] } if {$lname eq {content-transfer-encoding}} { error [list {use -encoding instead of -headers} $hkey $name] } if {$lname in {content-md5 mime-version}} { error [list {don't go there...}] } header::setinternal $token $name $hvalue } } lassign [$_ header get content-type] content dummy if {[info exists state(parts)]} { switch -glob $content { text/* - image/* - audio/* - video/* { error "-canonical $content and -parts do not mix" } default { if {$state(encoding) ne {}} { error "-encoding and -parts do not mix" } } } } set state(version) 1.0 return } if {[dict size $params]} { error "-param requires -canonical" } if {$state(encoding) ne {}} { error "-encoding requires -canonical" } if {[info exists headers]} { error "-header requires -canonical" } } proc mime::makeseekable token { upvar 0 $token state upvar 0 state(bodychan) bodychan state(fd) inputchan set chan2 [::tcllib::chan::base [info cmdcount]_chan [file tempfile]] chan configure $chan2 -translation binary chan copy $inputchan $chan2 incr size [tell $chan2] seek $chan2 0 close $inputchan set inputchan [::tcllib::chan::base [info cmdcount]_chan $chan2] return } # ::mime::mapencoding -- # # mime::mapencodings maps tcl encodings onto the proper names for their # MIME charset type. This is only done for encodings whose charset types # were known. The remaining encodings return {} for now. # # Arguments: # enc The tcl encoding to map. # # Results: # Returns the MIME charset type for the specified tcl encoding, or {} # if none is known. proc ::mime::mapencoding {enc} { variable encodings if {[info exists encodings($enc)]} { return $encodings($enc) } return {} } # ::mime::parsepart -- # # Parses the MIME headers and attempts to break up the message # into its various parts, creating a MIME token for each part. # # Arguments: # token The MIME token to parse. # # Results: # Throws an error if it has problems parsing the MIME token, # otherwise it just sets up the appropriate variables. proc ::mime::parsepart _ { set token [$_ token] upvar 0 $token state if {$state(canonicalP) || $state(bodyparsed)} { return } set state(bodyparsed) 1 parsepartaux $_ } proc ::mime::parsepartaux _ { set token [$_ token] # FRINK: nocheck upvar 0 $token state upvar 0 state(bodychan) bodychan state(eof) eof \ state(fd) fd state(size) size state(usemem) usemem state(relax) relax header::parse $token # although rfc 2045 5.2 defines a default treatment for content without a # type, don't automatically add an explicit content-type field #if {![header::exists $token content-type]} { # # rfc 2045 5.2 # header::setinternal $token Content-Type text/plain [ # dict create charset us-ascii] #} lassign [$_ contenttype] content params if {$usemem} { set bodychan [tcllib::chan::base .new [info cmdcount]_bodychan [ ::tcl::chan::memchan]] } else { set bodychan [tcllib::chan::base .new [info cmdcount]_bodychan] tcllib::chan::getslimit $bodychan $bodychan .init [file tempfile] } if {[dict exists $params charset]} { set charset [reversemapencoding [dict get $params charset]] if {$charset eq {}} { upvar 0 state(warnings) warnings lappend warnings [list {unknown charset} [ dict get $params charset] {using binary translation instead}] # but still do line automatic translation $fd configure -encoding binary -translation auto } else { $fd configure -encoding [reversemapencoding [dict get $params charset]] } } $bodychan configure -translation binary if {[info exists state(boundary)]} { set gets [list mimegets $token line] set iseof {$eof} } else { set gets [list $fd gets line] set iseof {[$fd eof] || $eof} } if {[string match multipart/* $content]} { set state(parts) {} dict update params boundary boundary {} if {![info exists state(boundary)]} { if {![info exists boundary]} { error "boundary parameter is missing in $content" } if {[string trim $boundary] eq {}} { error "boundary parameter is empty in $content" } } while 1 { if $iseof { break } if {![llength $state(parts)]} { set x [{*}$gets] if {$x == -1} { break } } if {[string first --$boundary-- $line] >= 0} { # No starting boundary was seen prior to the terminating boundary. # Interpret this to mean there are no more parts, and also attempt # to make a part from data already seen. # Covered by by test case mime-3.7, using "badmail1.txt". set state(sawclosing) 1 $bodychan puts $line $bodychan seek 0 set child [.new {} -chan $bodychan \ -root $state(root) -boundary $boundary -usemem $usemem] $child parsepart lappend state(parts) $child lappend state(dynamic) $child $child header setinternal Content-Type application/octet-stream break } elseif {[llength $state(parts)] || [string first --$boundary $line] == 0} { # either just saw the first boundary or saw a boundary between parts # do not brace this expression if $iseof { # either saw the closing boundary or reached the end of the file break } elseif {[string first --$boundary-- $line] >= 0} { set state(sawclosing) 1 break } else { #mimegets returned 0 because it found a border set child [.new {} -chan $fd \ -root $state(root) -boundary $boundary -usemem $usemem] $child parsepart lappend state(parts) $child lappend state(dynamic) $child upvar 0 $child childstate set state(sawclosing) $childstate(sawclosing) if {$childstate(eof)} break } } else { # Accumulate data in case the terminating boundary occurs starting # boundary was found, so that a part can be generated from data # seen so far. if $iseof { $bodychan puts -nonewline $line } else { $bodychan puts $line } set size [expr {$size + [ string length $line] + 1}] } } if {!$state(sawclosing) && ![dict get $relax finalboundary]} { error {end-of-string encountered while parsing multipart/form-data} } } else { if {[info exists state(boundary)]} { while 1 { set x [{*}$gets] if {$x == -1} { break } else { if {[incr linesout] > 1} { $bodychan puts -nonewline \n$line } else { $bodychan puts -nonewline $line } set size [expr {$size + [ string length $line] + 1}] } } } else { $fd copy [$bodychan configure -chan] set size [$bodychan tell] } $bodychan seek 0 if {[string match message/* $content]} { # FRINK: nocheck setencoding $token $bodychan setcharset $_ $bodychan set child [.new {} -chan $bodychan -usemem $usemem] lappend state(parts) $child lappend state(dynamic) $child $child parsepart } else { # this is undtrusted data, so keep the getslimit enabled on the # assumption that no one else wants to get hit by a long-line # attack either. #$bodychan configure -getslimit -1 } } return } # ::mime::property -- # # mime::property returns the properties of a MIME part. # # The properties are: # # property value # ======== ===== # content the type/subtype describing the content # encoding the "Content-Transfer-Encoding" # params a list of "Content-Type" parameters # parts a list of tokens for the part's subordinates # size the approximate size of the content {before decoding} # # The "parts" property is present only if the MIME part has # subordinates. # # If mime::property is invoked with the name of a specific # property, then the corresponding value is returned; instead, if # -names is specified, a list of all properties is returned; # otherwise, a dictionary of properties is returned. # # Arguments: # token The MIME token to parse. # property One of 'content', 'encoding', 'params', 'parts', and # 'size'. Defaults to returning a dictionary of # properties. # # Results: # Returns the properties of a MIME part proc ::mime::property {_ {property {}}} { set token [$_ token] # FRINK: nocheck upvar 0 $token state $_ parsepart lassign [$_ contenttype] content params switch $property { {} { array set properties [list content $content \ encoding $state(encoding) \ params $params \ size [getsize $_]] if {[info exists state(parts)]} { set properties(parts) $state(parts) } return [array get properties] } -names { set names [list content encoding params] if {[info exists state(parts)]} { lappend names parts } lappend nams size return $names } content - params { return [set $property] } encoding { return $state($property) } parts { if {![info exists state(parts)]} { error [list not a multipart message] } return $state(parts) } size { return [getsize $_] } default { error [list {unknown property} $property] } } } # ::mime::parseaddress -- # # This was originally written circa 1982 in C. we're still using it # because it recognizes virtually every buggy address syntax ever # generated! # # mime::parseaddress takes a string containing one or more 822-style # address specifications and returns a list of dictionaries, for each # address specified in the argument. # # Each dictionary contains these properties: # # property value # ======== ===== # address local@domain # comment 822-style comment # domain the domain part (rhs) # error non-empty on a parse error # group this address begins a group # friendly user-friendly rendering # local the local part (lhs) # memberP this address belongs to a group # phrase the phrase part # proper 822-style address specification # route 822-style route specification (obsolete) # # Note that one or more of these properties may be empty. # # Arguments: # string The address string to parse # # Results: # Returns a list of dictionaries, one element for each address # specified in the argument. proc ::mime::parseaddress {string args} { variable mime set token [namespace current]::[incr mime(uid)] # FRINK: nocheck upvar 0 $token state if {[llength $args]} { set string2 [lindex $args end] set args [list $string {*}[lrange $args 0 end-1]] set string $string2 } dict for {opt val} $args { switch $opt { hostname { set state(default_host) $val } } } catch {mime::parseaddressaux $token $string} result copts foreach name [array names state] { unset state($name) } # FRINK: nocheck catch {unset $token} return -options $copts $result } # ::mime::parseaddressaux -- # # This was originally written circa 1982 in C. we're still using it # because it recognizes virtually every buggy address syntax ever # generated! # # mime::parseaddressaux does the actually parsing for mime::parseaddress # # Each dictionary contains these properties: # # property value # ======== ===== # address local@domain # comment 822-style comment # domain the domain part (rhs) # error non-empty on a parse error # group this address begins a group # friendly user-friendly rendering # local the local part (lhs) # memberP this address belongs to a group # phrase the phrase part # proper 822-style address specification # route 822-style route specification (obsolete) # # Note that one or more of these properties may be empty. # # Arguments: # token The MIME token to work from. # string The address string to parse # # Results: # Returns a list of dictionaries, one for each address specified in the # argument. proc ::mime::parseaddressaux {token string} { # FRINK: nocheck upvar 0 $token state variable addrtokenL variable addrlexemeL set state(input) $string set state(glevel) 0 set state(buffer) {} set state(lastC) LX_END set state(tokenL) $addrtokenL set state(lexemeL) $addrlexemeL set result {} while {[addr_next $token]} { if {[set tail $state(domain)] ne {}} { set tail @$state(domain) } else { if {![info exists state(default_host)]} { set state(default_host) [info hostname] } set tail @$state(default_host) } if {[set address $state(local)] ne {}} { #TODO: this path is not covered by tests append address $tail } if {$state(phrase) ne {}} { #TODO: this path is not covered by tests set state(phrase) [string trim $state(phrase) \"] foreach t $state(tokenL) { if {[string first $t $state(phrase)] >= 0} { #TODO: is this quoting robust enough? set state(phrase) \"$state(phrase)\" break } } set proper "$state(phrase) <$address>" } else { set proper $address } if {[set friendly $state(phrase)] eq {}} { #TODO: this path is not covered by tests if {[set note $state(comment)] ne {}} { if {[string first ( $note] == 0} { set note [string trimleft [string range $note 1 end]] } if { [string last ) $note] == [set len [expr {[string length $note] - 1}]] } { set note [string range $note 0 [expr {$len - 1}]] } set friendly $note } if { $friendly eq {} && [set mbox $state(local)] ne {} } { #TODO: this path is not covered by tests set mbox [string trim $mbox \"] if {[string first / $mbox] != 0} { set friendly $mbox } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} { } elseif { [set friendly [addr_x400 $mbox S]] ne {} && [set g [addr_x400 $mbox G]] ne {} } { set friendly "$g $friendly" } if {$friendly eq {}} { set friendly $mbox } } } set friendly [string trim $friendly \"] lappend result [list address $address \ comment $state(comment) \ domain $state(domain) \ error $state(error) \ friendly $friendly \ group $state(group) \ local $state(local) \ memberP $state(memberP) \ phrase $state(phrase) \ proper $proper \ route $state(route)] } unset {*}{ state(input) state(glevel) state(buffer) state(lastC) state(tokenL) state(lexemeL) } return $result } # ::mime::parselexeme -- # # Used to implement a lookahead parser. # # Arguments: # token The MIME token to operate on. # # Results: # Returns the next token found by the parser. proc ::mime::parselexeme token { # FRINK: nocheck upvar 0 $token state set state(input) [string trimleft $state(input)] set state(buffer) {} if {$state(input) eq {}} { set state(buffer) end-of-input return [set state(lastC) LX_END] } set c [string index $state(input) 0] set state(input) [string range $state(input) 1 end] if {$c eq {(}} { set noteP 0 set quoteP 0 while 1 { append state(buffer) $c #TODO: some of these paths are not covered by tests switch $c/$quoteP { (/0 { incr noteP } \\/0 { set quoteP 1 } |
︙ | ︙ | |||
3563 3564 3565 3566 3567 3568 3569 | if {$c eq "\""} { set firstP 1 set quoteP 0 while 1 { append state(buffer) $c | | | 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 | if {$c eq "\""} { set firstP 1 set quoteP 0 while 1 { append state(buffer) $c switch $c/$quoteP { "\\/0" { set quoteP 1 } "\"/0" { if {!$firstP} { return [set state(lastC) LX_QSTRING] |
︙ | ︙ | |||
3594 3595 3596 3597 3598 3599 3600 | if {$c eq {[}} { set quoteP 0 while 1 { append state(buffer) $c | | | 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 | if {$c eq {[}} { set quoteP 0 while 1 { append state(buffer) $c switch $c/$quoteP { \\/0 { set quoteP 1 } ]/0 { return [set state(lastC) LX_DLITERAL] } |
︙ | ︙ | |||
3618 3619 3620 3621 3622 3623 3624 | } set state(input) [string range $state(input) 1 end] } } if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { append state(buffer) $c | < | < < < < < < < < < < < < < < < < < < < < < < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 | } set state(input) [string range $state(input) 1 end] } } if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { append state(buffer) $c return [set state(lastC) [lindex $state(lexemeL) $x]] } while 1 { append state(buffer) $c switch [set c [string index $state(input) 0]] { {} - " " - "\t" - "\n" { break } default { if {[lsearch -exact $state(tokenL) $c] >= 0} { break } } } set state(input) [string range $state(input) 1 end] } return [set state(lastC) LX_ATOM] } # ::mime::reversemapencoding -- # # mime::reversemapencodings maps MIME charset types onto tcl encoding names. # Those that are unknown return {}. # # Arguments: # mimeType The MIME charset to convert into a tcl encoding type. # # Results: # Returns the tcl encoding name for the specified mime charset, or {} # if none is known. proc ::mime::reversemapencoding mimeType { variable reversemap set lmimeType [string tolower $mimeType] if {[info exists reversemap($lmimeType)]} { return $reversemap($lmimeType) } return {} } proc ::mime::relax {token args} { upvar 0 $token state upvar 0 state(relax) relax foreach {key val} $args { switch $key { all { dict set relax finalboundary 1 } finalboundary { dict set relax $key [expr {!!$val}] } default { error [list {unknown value for -relax} $key {should be one of} { all finalboundary }] } } } } # ::mime::serialize -- # # Serializes a message to a value or a channel. # # Arguments: # token The MIME token to parse. # channel The channel to copy the message to. # # Results: # Returns nothing unless an error is thrown while the message # is being written to the channel. proc ::mime::serialize {_ args} { set level 0 set chan {} dict for {arg val} $args { switch $arg { -chan { if {$val eq {}} { error [list {chan must not be the empty string}] } set chan [uplevel 1 [list ::namespace which $val]] } -level { set level [expr {$val + 0}] } default { error [list {unknown option} $arg] } } } if {$chan eq {}} { set token [$_ token] upvar 0 $token state set code [catch {serialize_value $_ $level} result copts] return -options $copts $result } else { return [serialize_chan $_ $chan $level] } } proc ::mime::serialize_chan {_ channel level} { set token [$_ token] # FRINK: nocheck upvar 0 $token state upvar 0 state(bodychan) bodychan $_ parsepart set result {} if {!$level && $state(addmimeversion)} { $channel puts [header::serialize MIME-Version $state(version) {}] } contentid $_ if {![header::exists $token content-id] && $state(addcontentid)} { header::setinternal $token Content-ID [contentid $_] } if {![header::exists $token message-id] && $state(addmessageid)} { header::setinternal $token Message-ID [messageid $_] } foreach {name value} [$_ header get] { $channel puts [header::serialize $name {*}$value] } set converter {} set encoding {} if {![info exists state(parts)]} { if {$state(canonicalP)} { set encoding [getTransferEncoding $_] if {$encoding ne {}} { $channel puts "Content-Transfer-Encoding: $encoding" } } } if {[info exists state(error)]} { unset state(error) } if {[info exists state(parts)]} { lassign [$_ contenttype] content params set boundary [dict get $params boundary] switch -glob $content { message/* { $channel puts {} foreach part $state(parts) { serialize_chan $part $channel 1 break } } default { # Note RFC 2046: See serialize_value for details. # # The boundary delimiter MUST occur at the # beginning of a line, i.e., following a CRLF, and # the initial CRLF is considered to be attached to # the boundary delimiter line rather than part of # the preceding part. # # - The above means that the CRLF before $boundary # is needed per the RFC, and the parts must not # have a closing CRLF of their own. See Tcllib bug # 1213527, and patch 1254934 for the problems when # both file/string branches added CRLF after the # body parts. foreach part $state(parts) { $channel puts \n--$boundary serialize_chan $part $channel 1 } $channel puts \n--$boundary-- } } } else { $channel puts {} if {$state(canonicalP)} { set transforms [setencoding $token $channel] $state(fd) seek 0 $state(fd) copy [$channel $ chan] while {[incr transforms -1] >= 0} { $channel $channel } } else { $state(bodychan) seek 0 $state(bodychan) copy [$channel $ chan] } } $channel flush if {[info exists state(error)]} { error $state(error) } } proc ::mime::serialize_value {_ level} { set chan [::tcllib::chan::base .new [info cmdcount]_serialize_value [ tcl::chan::memchan]] $chan configure -translation crlf serialize_chan $_ $chan $level $chan seek 0 $chan configure -translation binary set res [$chan read] $chan close return $res } proc ::mime::setencoding {token chan} { upvar 0 $token state set transforms 0 if {[info exists state(encoding)]} { switch $state(encoding) { base64 { package require tcl::transform::base64 ::tcl::transform::base64 [$chan configure -chan] incr transforms } quoted-printable { package require {tcl transform qp} ::tcl::transform::qp [$chan configure -chan] incr transforms } 7bit - 8bit - binary - {} { # Bugfix for [#477088] # Go ahead, leave chunk alone } default { error [list {Can't handle content encoding} $state(encoding)] } } } return $transforms } proc ::mime::setcharset {_ chan} { set token [$_ token] upvar 0 $token state lassign [$_ contenttype] content params if {[dict exists $params charset]} { set mcharset [dict get $params charset] } else { switch $state(spec) { cgi - http { set mcharset UTF-8 } mime - default { # mime set mcharset US-ASCII } } } set encoding [reversemapencoding $mcharset] if {$encoding eq {}} { $chan configure -translation binary } else { $chan configure -encoding $encoding } return } # ::mime::uniqueID -- # # Used to generate a 'globally unique identifier' for the content-id. # The id is built from the pid, the current time, the hostname, and # a counter that is incremented each time a message is sent. # # Arguments: # # Results: # Returns the a string that contains the globally unique identifier # that should be used for the Content-ID of an e-mail message. proc ::mime::uniqueID {} { set id [base64 -mode encode -- [ sha2::sha256 -bin [expr {rand()}][pid][clock clicks][array get state]]] return $id } # ::mime::unquote # # Removes any enclosing quotes and unquotes quoted pairs in a string. proc ::mime::unquote string { set qstring [string match "\"*" $string] regsub -all {\\(.)} $string[set string {}] {\1} string # this isn't exactly right because it doesn't validate that a quote at the # end of the string wsan't just replaced as part of a quoted pair. if {$qstring} { regexp {^["]?(.*?)["]?$} $string[set string {}] -> string # a quote for vim syntax coloring: " } return $string } # ::mime::word_encode -- # # Word encodes strings as per RFC 2047. # # Arguments: # charset The character set to encode the message to. |
︙ | ︙ | |||
3710 3711 3712 3713 3714 3715 3716 | # Returns a word encoded string. proc ::mime::word_encode {charset method string {args}} { variable encodings if {![info exists encodings($charset)]} { | | | | > | | 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 | # Returns a word encoded string. proc ::mime::word_encode {charset method string {args}} { variable encodings if {![info exists encodings($charset)]} { error [list {unknown charset} $charset] } if {$encodings($charset) eq {}} { error [list {invalid charset} $charset] } if {$method ne {base64} && $method ne {quoted-printable}} { error [list {unknown method} $method {must be one of} \ {base64 quoted-printable}] } # default to encoded and a length that won't make the Subject header to long array set options [list -charset_encoded 1 -maxlength 66] array set options $args if {$options(-charset_encoded)} { |
︙ | ︙ | |||
3741 3742 3743 3744 3745 3746 3747 | return {} } set string_bytelength [string bytelength $unencoded_string] # the 7 is for =?, ?Q?, ?= delimiters of the encoded word set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}] | | > | | 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 | return {} } set string_bytelength [string bytelength $unencoded_string] # the 7 is for =?, ?Q?, ?= delimiters of the encoded word set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}] switch -exact $method { base64 { if {$maxlength < 4} { error [list maxlength $options(-maxlength) \ {too short for chosen charset and encoding}] } set count 0 set maxlength [expr {($maxlength / 4) * 3}] while {$count < $string_length} { set length 0 set enc_string {} while {$length < $maxlength && $count < $string_length} { |
︙ | ︙ | |||
3773 3774 3775 3776 3777 3778 3779 | # Trim off last "\n ", since the above code has the side-effect # of adding an extra "\n " to the encoded string. set result [string range $result 0 end-2] } quoted-printable { if {$maxlength < 1} { | > | | > | | 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 | # Trim off last "\n ", since the above code has the side-effect # of adding an extra "\n " to the encoded string. set result [string range $result 0 end-2] } quoted-printable { if {$maxlength < 1} { error [list maxlength $options(-maxlength) \ {too short for chosen charset and encoding}] } set count 0 while {$count < $string_length} { set length 0 set encoded_word {} while {$length < $maxlength && $count < $string_length} { set char [string range $unencoded_string $count $count] set enc_char [::encoding convertto $charset $char] set qp_enc_char [qp::encode $enc_char 1] set qp_enc_char_length [string length $qp_enc_char] if {$qp_enc_char_length > $maxlength} { error [list maxlength $options(-maxlength) \ {too short for chosen charset and encoding}] } if { $length + [string length $qp_enc_char] > $maxlength } { set length $maxlength } else { append encoded_word $qp_enc_char |
︙ | ︙ | |||
3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 | } default { error "Can't handle content encoding \"$method\"" } } return $result } # ::mime::word_decode -- # # Word decodes strings that have been word encoded as per RFC 2047. # # Arguments: # encoded The word encoded string to decode. | > | 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 | } default { error "Can't handle content encoding \"$method\"" } } return $result } # ::mime::word_decode -- # # Word decodes strings that have been word encoded as per RFC 2047. # # Arguments: # encoded The word encoded string to decode. |
︙ | ︙ | |||
3839 3840 3841 3842 3843 3844 3845 | } set enc [reversemapencoding $charset] if {$enc eq {}} { error "unknown charset '$charset'" } | | | | > | 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 | } set enc [reversemapencoding $charset] if {$enc eq {}} { error "unknown charset '$charset'" } switch -exact $method { b - B { set method base64 } q - Q { set method quoted-printable } default { error "unknown method '$method', must be B or Q" } } switch -exact $method { base64 { set result [base64 -mode decode -- $string] } quoted-printable { set result [qp::decode $string 1] } {} { # Go ahead } default { error "Can't handle content encoding \"$method\"" } } return [list $enc $method $result] } # ::mime::field_decode -- # # Word decodes strings that have been word encoded as per RFC 2047 # and converts the string from the original encoding/charset to UTF. # # Arguments: |
︙ | ︙ | |||
3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 | } set decoded [word_decode $encoded] foreach {charset - string} $decoded break append result [::encoding convertfrom $charset $string] } append result $field return $result } ## One-Shot Initialization ::apply {{} { variable encList variable encAliasList variable reversemap foreach {enc mimeType} $encList { if {$mimeType eq {}} continue set reversemap([string tolower $mimeType]) $enc } foreach {enc mimeType} $encAliasList { set reversemap([string tolower $mimeType]) $enc } # Drop the helper variables unset encList encAliasList } ::mime} variable ::mime::internal 0 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 | } set decoded [word_decode $encoded] foreach {charset - string} $decoded break append result [::encoding convertfrom $charset $string] } append result $field return $result } namespace eval ::mime::header { ::apply [list {} { set saved [namespace eval [namespace parent] { namespace export }] namespace eval [namespace parent] { namespace export * } namespace import [namespace parent]::getTransferEncoding namespace import [namespace parent]::parselexeme namespace import [namespace parent]::reversemapencoding namespace import [namespace parent]::uniqueID namespace import [namespace parent]::unquote namespace eval [namespace parent] [ list namespace export -clear {*}$saved ] } [namespace current]] } ## One-Shot Initialization ::apply {{} { variable encList variable encAliasList variable reversemap variable timeformats foreach {enc mimeType} $encList { if {$mimeType eq {}} continue set reversemap([string tolower $mimeType]) $enc } foreach {enc mimeType} $encAliasList { set reversemap([string tolower $mimeType]) $enc } set formats1 { {%a, %d %b %Y %H:%M:%S %z} {%a, %d %b %Y %H:%M %z} {%a , %d %b %Y %H:%M:%S %z} {%a , %d %b %Y %H:%M %z} {%d %b %Y %H:%M:%S %z} {%d %b %Y %H:%M %z} } set timeformats [list {*}$formats1 {*}[string map {%Y %y} $formats1]] # Drop the helper variables unset encList encAliasList } ::mime} variable ::mime::internal 0 |
Changes to modules/mime/mime.test.
1 2 3 4 | # mime.test - Test suite for TclMIME -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and | | > | | | | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | | | < | > | | | > > > > > > > > > > > > > | | | | | < | | < | > > > > > > > > | | > > > > > > > > > > | | > > > > > > > > > > > > > > > | | | | > | < | | | | > | | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | # mime.test - Test suite for TclMIME -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # genere totes output for errors. No output means no errors were found. # # Copyright (c) 2000 by Ajuba Solutions # Copyright (c) 2018 by Poor Yorick # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file dirname [ file normalize [info script]/...]]]]/devtools/testutilities.tcl] testsNeedTcl 8.6.9 testsNeedTcltest 2 support { # This code loads md5x, i.e. md5 v2. Proper testing should do one # run using md5 v1, aka md5.tcl as well. use md5/md5x.tcl md5 use namespacex/namespacex.tcl namespacex } testing { useLocal mime.tcl mime } package require {chan base} # ------------------------------------------------------------------------- namespace import mime::datetime mime::field_decode mime::mapencoding \ mime::.new mime::parseaddress mime::qp mime::reversemapencoding \ mime::word_decode mime::word_encode # ------------------------------------------------------------------------- proc channamescmp names { expr {[llength $names] == [llength [chan names]]} } proc cleanly script { set ns [info cmdcount] namespace eval $ns { namespace path [namespace parent] } catch {namespace eval $ns $script} cres copts foreach name [info vars ${ns}::*] { set val [set $name] if {[namespace which $val] ne {} && [string match ::mime* $val]} { rename $val {} } } namespace delete $ns return -options $copts $cres } proc setup1 {} { uplevel 1 { set channames [chan names] } } proc with.chan {name args} { set body [lindex $args end] set args [lrange $args 0 end-1] set chan chan_[info cmdcount] ::tcllib::chan::base .new $chan [open $name] uplevel 1 [list set tok [.new {} {*}$args -chan $chan]] try { uplevel 1 $body } finally { rename $chan {} } } proc with.file {name args} { set body [lindex $args end] set args [lrange $args 0 end-1] uplevel 1 [list set tok [.new {} {*}$args -file $name]] uplevel 1 $body } proc main {} { variable encoded variable name variable n set message1 {MIME-Version: 1.0 Content-Type: Text/plain I'm the message.} test mime-1.1 {.new with no args} {cleanly { catch .new res subst $res }} {{specify exactly one of} {-chan -file -parts -string}} test mime-2.1 {Generate a MIME message} {cleanly { set tok [.new {} -canonical Text/plain -string {jack and jill}] set msg [$tok serialize] }} "MIME-Version: 1.0\r Message-ID: <ac7319c5a872e80af7fe7fb7efa5fd7ac7356ec74eb4410d23287b6cf7fa0129@|>\r Content-ID: <8e84af0326e6170dfb2720eeb49b23337250b571c563247605c9ec6910772d2c@|>\r Content-Type: text/plain\r \r jack and jill" test mime-2.1.1 {Generate a MIME message} {cleanly { setup1 with.chan [makeFile {jack and jill} input.txt] -canonical Text/plain { set msg [[$tok body raw] read] $tok .destroy # The generated message is predictable except for the Content-ID lappend res $msg lappend res [channamescmp $channames] return $res } }} [list "jack and jill\n" 1] test mime-2.2 {Generate a multi-part MIME message} {cleanly { set tok1 [.new {} -canonical Text/plain -string {jack and jill}] set tok2 [.new {} -canonical Text/plain -string james] set bigTok [.new {} -canonical Multipart/MyType \ -params [list MyParam foo boundary bndry] \ -headers [list Content-Description {Test Multipart}] \ -parts [list $tok1 $tok2]] $bigTok serialize }} "MIME-Version: 1.0\r Message-ID: <0b1ce38bc23a7af000d136b6227d7e47af437c850c83145d8ae807bb4ab4d748@|>\r Content-ID: <b534a48db81537371fd048c0fc6da3047924c773b8f1b1691df58d032ed717c1@|>\r Content-Type: multipart/mytype\r ; myparam=foo\r ; boundary=bndry\r Content-Description: Test Multipart\r \r --bndry\r Message-ID: <ac7319c5a872e80af7fe7fb7efa5fd7ac7356ec74eb4410d23287b6cf7fa0129@|>\r Content-ID: <8e84af0326e6170dfb2720eeb49b23337250b571c563247605c9ec6910772d2c@|>\r Content-Type: text/plain\r \r jack and jill\r --bndry\r Message-ID: <ab7737bc7bbff0d4096ba7e130fd69e77ea5a1e1d7618d17e15f4914bae8600f@|>\r Content-ID: <119c9ae6f9ca741bd0a76f87fba0b22cab5413187afb2906aa2875c38e213603@|>\r Content-Type: text/plain\r \r james\r --bndry--\r " test mime-2.3 {Generate a multi-part MIME message} {cleanly { set tok1 [.new {} -canonical Text/plain -string {jack and jill}] set tok2 [.new {} -canonical Text/plain -string james] set bigTok [.new {} \ -params [list MyParam foo boundary bndry] \ -headers [list Content-Description {Test Multipart}] \ -parts [list $tok1 $tok2]] $bigTok serialize }} "MIME-Version: 1.0\r Message-ID: <6fd7e9b06fe3961dbc67d3bcc058451c3674403801ed18714d11aa200aed02a2@|>\r Content-ID: <b534a48db81537371fd048c0fc6da3047924c773b8f1b1691df58d032ed717c1@|>\r Content-Type: multipart/mixed\r ; myparam=foo\r ; boundary=bndry\r Content-Description: Test Multipart\r \r --bndry\r Message-ID: <ac7319c5a872e80af7fe7fb7efa5fd7ac7356ec74eb4410d23287b6cf7fa0129@|>\r Content-ID: <8e84af0326e6170dfb2720eeb49b23337250b571c563247605c9ec6910772d2c@|>\r Content-Type: text/plain\r \r jack and jill\r --bndry\r Message-ID: <ab7737bc7bbff0d4096ba7e130fd69e77ea5a1e1d7618d17e15f4914bae8600f@|>\r Content-ID: <119c9ae6f9ca741bd0a76f87fba0b22cab5413187afb2906aa2875c38e213603@|>\r Content-Type: text/plain\r \r james\r --bndry--\r " test mime-3.1 {Parse a MIME message} {cleanly { set msg {MIME-Version: 1.0 Content-Type: Text/plain I'm the message.} set tok [.new {} -string $msg] [$tok body raw] read }} {I'm the message.} test mime-3.2 {Parse a multi-part MIME message} {cleanly { set msg {MIME-Version: 1.0 Content-Type: Multipart/foo; boundary="bar" --bar MIME-Version: 1.0 Content-Type: Text/plain |
︙ | ︙ | |||
107 108 109 110 111 112 113 | MIME-Version: 1.0 Content-Type: Text/plain part3 --bar-- } | | | | | | > | | > | > | | | | | > > > | | > > | | < > > > > > > > > > > > < < < < < < < < | | | | > | | | | | > | > > > > > > > | > > > > > | | | | | | | | > | | > > | | | | > | | | | > | | | | < < < < < < < < < < | | > > | > | > > | | | > | | | | > | | | > | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | > | < < > > | > | | | | > | | | > | | | > | | | > | | | > | | | | | | > | | | | | | | | | | | | | | | > | | | > | | | > | | | > | | | > | | | > | | | > | | | > | | | > | | < > > | | | > | | | > | | | | | | > | | | > | | | > | | | > | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | > | | | | > | | | | > | | | | < | | | | | | | | | | | > > | | > | | | | | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | MIME-Version: 1.0 Content-Type: Text/plain part3 --bar-- } set tok [.new {} -string $msg] set partToks [$tok property parts] set res {} foreach childTok $partToks { lappend res [[$childTok body raw] read] } set res }} [list part1 part2 part3] test mime-3.3 {Try to parse a totally invalid message} {cleanly { set token [.new {} -string blah] catch {$token header get} err0 set err0 }} {{improper line in header} blah} test mime-3.4 {Try to parse a MIME message with an invalid version} {cleanly { set msg1 {MIME-Version: 2.0 Content-Type: text/plain msg1} set tok [.new {} -string $msg1] catch {[$tok body raw] read} err1 catch {$tok serialize} err1a list $err1 $err1a }} "msg1 {MIME-Version: 2.0\r Message-ID: <d956986793d51d614044c01a7e7650665330a4a170d071aff1de6dceda8c8b0d@|>\r Content-ID: <289e5175e02c788c2d442cfe81d6be0533d8c13e253ef763fda45d37accfe4d4@|>\r Content-Type: text/plain\r \r msg1}" test mime-3.5 {Try to parse a MIME message with no newline between headers and data} {cleanly { set msg2 {MIME-Version: 1.0 Content-Type: foobar data without newline} .new mime1 -string $msg2 catch {mime1 header get} err2 set err2 }} {expecting type/subtype found foobar} test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} {cleanly { # No MIME version set msg3 {Content-Type: text/plain foo} .new mime1 -string $msg3 catch {[mime1 body raw] read} err3 catch {mime1 serialize} err3a copts list $err3 $err3a }} "foo {MIME-Version: 1.0\r Message-ID: <fb8bfc091f5ff55264834b7ea21278fbcb7bf875b20ddeae2f5e4eb662de2129@|>\r Content-ID: <2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae@|>\r Content-Type: text/plain\r \r foo}" foreach name {file chan} { test mime-3.7.$name {Test mime with a bad email [SF Bug 631314 ]} {cleanly { with.$name $tcltest::testsDirectory/badmail1.txt { set res {} lappend res [llength [$tok property parts]] set ctok [lindex [$tok property parts] 0] lappend res [dictsort [$tok property]] lappend res [dictsort [$ctok property]] $tok .destroy string map [list $ctok CHILD] $res } }} {1 {content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {} size 0}} } foreach name {file chan} { test mime-3.8.1.$name {Test mime with another bad email [SF Bug 631314 ]} -body {cleanly { with.$name $tcltest::testsDirectory/badmail2.txt { set ctok [lindex [$tok property parts] 0] } }} -returnCodes 1 -result {end-of-string encountered while parsing multipart/form-data} } foreach name {file chan} { test mime-3.8.2.$name {Test mime with another bad email [SF Bug 631314 ]} {cleanly { with.$name $tcltest::testsDirectory/badmail2.txt -relax finalboundary { set res {} set ctok [lindex [$tok property parts] 0] lappend res [dictsort [$tok property]] lappend res [dictsort [$ctok property]] $tok .destroy string map [list $ctok CHILD] $res } }} {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 879} {content text/html encoding base64 params {} size 879}} } test mime-3.9 {Parse a MIME message with a charset encoded body and use [body decoded] to get it back} {cleanly { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Fran\xE7ois } set tok [.new {} -string $msg] [$tok body decoded] read }} {Fran\xE7ois } test mime-3.10 {Parse a MIME message with a charset encoded body and use [body decoded] to get it back (example from encoding man page)} {cleanly { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=EUC-JP Content-Transfer-Encoding: quoted-printable =A4=CF} set tok [.new {} -string $msg] [$tok body decoded] read }} \u306F test mime-3.11 {Parse a MIME message without a charset encoded body and use [body decoded] to get it back} {cleanly { set msg {MIME-Version: 1.0 Content-Type: text/plain Content-Transfer-Encoding: quoted-printable A plain text message.} set tok [.new {} -string $msg] [$tok body decoded] read }} {A plain text message.} test mime-3.12 {Parse a MIME message with a charset encoded body in an unrecognised charset and use [body decoded] to attempt to get it back} {cleanly { set msg {MIME-Version: 1.0 Content-Type: text/plain; charset=SCRIBBLE Content-Transfer-Encoding: quoted-printable This is a message in the scribble charset that tcl does not recognise.} set tok [.new {} -string $msg] lappend res [$tok header get content-type] lappend res [[$tok body decoded] configure -encoding] catch {[$tok body decoded] read} errmsg lappend res $errmsg }} {{text/plain {charset SCRIBBLE}} binary {This is a message in the scribble charset that tcl does not recognise.}} test mime-4.1 {Test qp::encode with a > 76 character string containing special chars.} {cleanly { set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\"" qp encode $str1 }} "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22" test mime-4.2 {Check that encode/decode yields original string} {cleanly { set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\" " set enc [qp encode $str1] set dec [qp decode $enc] string equal $dec $str1 }} 1 test mime-4.3 {decode data that might come from an MUA} {cleanly { set enc "I'm the =22 message =\nwith some new lines= \n but with some extra space, too. " qp decode $enc }} "I'm the \" message with some new lines but with some extra space, too." test mime-4.4 {Test qp::encode with non-US_ASCCI characters.} {cleanly { set str1 "Test de caractères accentués : â î é ç et quelques contrôles \"\[|\]()\"" qp encode $str1 }} "Test de caract=E8res accentu=E9s : =E2 =EE =E9 =E7 et quelques contr=F4le=\ns =22=5B=7C=5D()=22" test mime-4.5 {Test qp::encode with softbreak} {cleanly { set str1 [string repeat abc 40] qp encode $str1 }} "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabca= bcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc" test mime-4.6 {Test qp::encode with softbreak} {cleanly { set str1 [string repeat abc 40] qp encode $str1 0 1 }} [string repeat abc 40] test mime-4.7 {Test qp::encode/decode in encoded_word mode} {cleanly { set enc [qp encode {jack and jill went up the hill} 1] qp decode $enc 1 }} {jack and jill went up the hill} test mime-4.8 {Test qp::encode in encoded_word mode with equal signs} {cleanly { qp encode 1and1=2 1 }} 1and1=3D2 test mime-4.9 {Test qp::encode in encoded_word mode with tabs and spaces} {cleanly { qp encode "1 and 1 =\t2" 1 }} 1_and_1_=3D=092 test mime-4.10 {Test qp::encode in encoded_word mode with underscores} {cleanly { qp encode 2003_06_30 1 }} 2003=5F06=5F30 test mime-4.11 {Test qp::encode in encoded_word mode with underscores and spaces} {cleanly { qp encode {2003_06_30 is 30 June 2003} 1 }} 2003=5F06=5F30_is_30_June_2003 test mime-4.12 {Test qp::encode in encoded_word mode with question marks} {cleanly { qp encode {How long is a piece of string ?} 1 }} How_long_is_a_piece_of_string_=3F test mime-4.13 {Test qp::encode in no_softbreak mode} {cleanly { qp encode {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility} 0 1 }} {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility} test mime-5.1 {Test word_encode with quoted-printable method} {cleanly { word_encode iso8859-1 quoted-printable {Test de contrôle effectué} }} =?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?= test mime-5.2 {Test word_encode with base64 method} {cleanly { word_encode iso8859-1 base64 {Test de contrôle effectué} }} =?ISO-8859-1?B?VGVzdCBkZSBjb250cvRsZSBlZmZlY3R16Q==?= test mime-5.3 {Test encode+decode with quoted-printable method} {cleanly { set enc [word_encode iso8859-1 quoted-printable {Test de contrôle effectué}] word_decode $enc }} {iso8859-1 quoted-printable {Test de contrôle effectué}} test mime-5.4 {Test encode+decode with base64 method} {cleanly { set enc [word_encode iso8859-1 base64 {Test de contrôle effectué}] word_decode $enc }} {iso8859-1 base64 {Test de contrôle effectué}} test mime-5.5 {Test decode with lowercase quoted-printable method} {cleanly { word_decode =?ISO-8859-1?q?Test_lowercase_q?= }} {iso8859-1 quoted-printable {Test lowercase q}} test mime-5.6 {Test decode with lowercase base64 method} {cleanly { word_decode =?ISO-8859-1?b?VGVzdCBsb3dlcmNhc2UgYg==?= }} {iso8859-1 base64 {Test lowercase b}} test mime-5.7 {Test word_encode with quoted-printable method across encoded word boundaries} {cleanly { word_encode iso8859-1 quoted-printable {Test de contrôle effectué} -maxlength 31 }} "=?ISO-8859-1?Q?Test_de_contr?= =?ISO-8859-1?Q?=F4le_effectu?= =?ISO-8859-1?Q?=E9?=" test mime-5.8 {Test word_encode with quoted-printable method across encoded word boundaries} {cleanly { word_encode iso8859-1 quoted-printable {Test de contrôle effectué} -maxlength 32 }} "=?ISO-8859-1?Q?Test_de_contr?= =?ISO-8859-1?Q?=F4le_effectu?= =?ISO-8859-1?Q?=E9?=" test mime-5.9 {Test word_encode with quoted-printable method and multibyte character} {cleanly { word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" }} =?EUC-JP?Q?Following_me_is_a_multibyte_character_=A4=CF?= set n 10 while {$n < 14} { test mime-5.$n {Test word_encode with quoted-printable method and multibyte character across encoded word boundary} {cleanly { word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" -maxlength [expr 42 + $n] }} "=?EUC-JP?Q?Following_me_is_a_multibyte_character_?= =?EUC-JP?Q?=A4=CF?=" incr n } test mime-5.14 {Test word_encode with quoted-printable method and multibyte character (triple)} {cleanly { word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" }} =?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?= set n 15 while {$n < 23} { test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} {cleanly { word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n] }} "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_?= =?UTF-8?Q?=E3=81=AF?=" incr n } while {$n < 25} { test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} {cleanly { word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n] }} =?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?= incr n } while {$n < 29} { test mime-5.$n {Test word_encode with base64 method across encoded word boundaries} {cleanly { word_encode euc-jp base64 "There is a multibyte character \xA4\xCF" -maxlength [expr 28 + $n] }} "=?EUC-JP?B?VGhlcmUgaXMgYSBtdWx0aWJ5dGUgY2hhcmFjdGVy?= =?EUC-JP?B?IKTP?=" incr n } while {$n < 33} { test mime-5.$n {Test word_encode with base64 method and triple byte character across encoded word boundary} {cleanly { word_encode utf-8 base64 "Here is a multibyte character \xE3\x81\xAF" -maxlength [expr 23 + $n] }} "=?UTF-8?B?SGVyZSBpcyBhIG11bHRpYnl0ZSBjaGFyYWN0ZXIg?= =?UTF-8?B?44Gv?=" incr n } test mime-5.33 {Test word_encode with quoted-printable method and -maxlength set to same length as will the result} {cleanly { word_encode iso8859-1 quoted-printable 123 -maxlength 20 }} =?ISO-8859-1?Q?123?= test mime-5.34 {Test word_encode with base64 method and -maxlength set to same length as will the result} {cleanly { word_encode iso8859-1 base64 123 -maxlength 21 }} =?ISO-8859-1?B?MTIz?= test mime-5.35 {Test word_encode with quoted-printable method and non charset encoded string} {cleanly { word_encode utf-8 quoted-printable \u306F -charset_encoded 0 }} =?UTF-8?Q?=E3=81=AF?= test mime-5.36 {Test word_encode with base64 method and non charset encoded string} {cleanly { word_encode utf-8 base64 \u306F -charset_encoded 0 }} =?UTF-8?B?44Gv?= test mime-5.36 {Test word_encode with base64 method and one byte} {cleanly { word_encode iso8859-1 base64 a }} =?ISO-8859-1?B?YQ==?= test mime-5.37 {Test word_encode with base64 method and two bytes} {cleanly { word_encode euc-jp base64 \xA4\xCF }} =?EUC-JP?B?pM8=?= test mime-5.38 {Test word_encode with unknown charset} {cleanly { catch {word_encode scribble quoted-printable {scribble is an unknown charset}} errmsg set errmsg }} {{unknown charset} scribble} test mime-5.39 {Test word_encode with invalid charset} {cleanly { catch {word_encode unicode quoted-printable {unicode is not a valid charset}} errmsg set errmsg }} {{invalid charset} unicode} test mime-5.40 {Test word_encode with invalid method} {cleanly { catch {word_encode iso8859-1 tea-leaf {tea-leaf is not a valid method}} errmsg set errmsg }} {{unknown method} tea-leaf {must be one of} {base64 quoted-printable}} test mime-5.41 {Test word_encode with maxlength to short for method quoted-printable} {cleanly { catch {word_encode iso8859-1 quoted-printable 1 -maxlength 17} errmsg set errmsg }} {maxlength 17 {too short for chosen charset and encoding}} test mime-5.42 {Test word_encode with maxlength on the limit for quoted_printable and an unquoted character} {cleanly { catch {word_encode iso8859-1 quoted-printable _ -maxlength 20} errmsg set errmsg }} =?ISO-8859-1?Q?=5F?= test mime-5.43 {Test word_encode with maxlength to short for method quoted_printable and a character to be quoted} {cleanly { catch {word_encode iso8859-1 quoted-printable = -maxlength 18} errmsg set errmsg }} {maxlength 18 {too short for chosen charset and encoding}} test mime-5.44 {Test word_encode with maxlength to short for method quoted-printable and multibyte character} {cleanly { catch {word_encode euc-jp quoted-printable \xA4\xCF -maxlength 17} errmsg set errmsg }} {maxlength 17 {too short for chosen charset and encoding}} test mime-5.45 {Test word_encode with maxlength to short for method base64} {cleanly { catch {word_encode iso8859-1 base64 1 -maxlength 20} errmsg set errmsg }} {maxlength 20 {too short for chosen charset and encoding}} test mime-6.1 {Test field_decode (from RFC 2047, part 8)} {cleanly { field_decode {=?US-ASCII?Q?Keith_Moore?= <[email protected]>} }} {Keith Moore <[email protected]>} test mime-6.2 {Test field_decode (from RFC 2047, part 8)} {cleanly { field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <[email protected]>} }} {Patrik Fältström <[email protected]>} test mime-6.3 {Test field_decode (from RFC 2047, part 8)} {cleanly { field_decode {=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=} }} {If you can read this you understand the example.} foreach {n encoded expected} { 4 (=?ISO-8859-1?Q?a?=) (a) 5 {(=?ISO-8859-1?Q?a?= b)} {(a b)} 6 {(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)} (ab) 7 {(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)} (ab) 8 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)" (ab) 9 (=?ISO-8859-1?Q?a_b?=) {(a b)} 10 {(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)} {(a b)} 11 {(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)} {(ax b)} 12 {a b c} {a b c} 13 {} {} } { test mime-6.$n {Test field_decode (from RFC 2047, part 8)} {cleanly { field_decode $encoded }} $expected ; # {} } foreach {bug n encoded expected} { 764702 1 {(=?utf-8?Q?H=C3=BCrz?=)} {(Hürz)} } { test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" {cleanly { field_decode $encoded }} $expected ; # {} } test mime-8.1 {Test reversemapencoding+mapencoding with preferred name} {cleanly { set charset [reversemapencoding US-ASCII] mapencoding $charset }} US-ASCII test mime-8.2 {Test reversemapencoding+mapencoding with alias} {cleanly { set charset [reversemapencoding UTF8] mapencoding $charset }} UTF-8 foreach name {file chan} { test mime-9.0.$name {Test chunk handling of serialize and helpers} {cleanly { set in [makeFile [set data [string repeat [string repeat {123456789 } 10]\n 350]] input.txt] set mi [makeFile {} mime.txt] with.$name $in -canonical text/plain { ::tcllib::chan::base .new chan1 [open $mi w] chan1 configure -translation binary $tok serialize -chan chan1 chan1 close with.$name $mi { set newdata [[$tok body raw] read] set res [string compare $data $newdata] removeFile input.txt removeFile mime.txt unset data newdata tok in mi set res } } }} 0 } set ::env(TZ) UTC0 set epoch [clock scan 2000-01-01] foreach {n stamp date} { 1 86340 {Sat, 01 Jan 2000 23:59:00 +0000} 2 5176620 {Tue, 29 Feb 2000 21:57:00 +0000} 3 31610520 {Sun, 31 Dec 2000 20:42:00 +0000} 4 31708740 {Mon, 01 Jan 2001 23:59:00 +0000} 5 68248620 {Thu, 28 Feb 2002 21:57:00 +0000} 6 126218520 {Wed, 31 Dec 2003 20:42:00 +0000} } { test mime-10.$n "Test formatting dates (RFC 822)" { # To verify that clock scan gets the expected value. set stamp_test [expr {[datetime $date clock] - $epoch}] # Parse and re-format should get us the original. set parsed_test [datetime $date proper] list $stamp_test $parsed_test } [list $stamp $date] } test mime-11.0 {Bug 1825092} {cleanly { set in [makeFile {From [email protected] Sat Oct 20 17:58:49 2007 Return-Path: <[email protected]> Message-ID: <[email protected]> From: Somwhere <[email protected]> MIME-Version: 1.0 To: Here <[email protected]> Subject: test |
︙ | ︙ | |||
588 589 590 591 592 593 594 | Content-Type: application/octet-stream; name="a0036.dss" BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ --------------090305080603000703000106-- } mail_part] | | | | | | | > > | > | | < < > | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 | Content-Type: application/octet-stream; name="a0036.dss" BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ --------------090305080603000703000106-- } mail_part] set token [.new {} -file $in] set allparts [$token property parts] set attachment [lindex $allparts 1] set out [makeFile {} mail_att] ::tcllib::chan::base .new chan1 [open $out w] chan1 configure -translation binary $attachment serialize -chan chan1 -level 1 chan1 close set data [viewFile $out] file delete $in $out set data }} {Message-ID: <f60c78370648168a30158b8cda876db2f875d1531e86e5594c5a108dcf5209db@|> Content-ID: <93755e1312eacd488b6170673caa5e7a9a9445ce82ff11c934055bd1f907b229@|> Content-Type: application/octet-stream ; name=a0036.dss Content-Disposition: attachment ; filename=a0036.dss Content-Transfer-Encoding: base64 BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ} # ------------------------------------------------------------------------- test mime-12.0 {Bug 3483716} {cleanly { set token [.new {} -string {Content-Type: message/delivery-status; name="deliverystatus.txt" Content-Disposition: attachment; filename="deliverystatus.txt"; size=138; creation-date="Thu, 02 Feb 2012 13:50:05 GMT"; modification-date="Thu, 02 Feb 2012 13:50:05 GMT" Content-Description: deliverystatus.txt Content-Transfer-Encoding: base64 T3JpZ2luYWwtUmVjaXBpZW50OiA8L2ZheD1ibHViYkBndW1taS5ib290PgpBY3Rpb246IGZhaWxl ZApEaWFnbm9zdGljLUNvZGU6IHNtdHA7IDU1MCAjNS4xLjAgQWRkcmVzcyByZWplY3RlZC4KUmVt b3RlLU1UQTogNTMuMjQuMjgyLjE1MA== }] set parts [$token property parts] set result [[lindex $parts end] header get Remote-MTA] return $result }} {53.24.282.150 {}} # ------------------------------------------------------------------------- test mime-13.0 {cleanly { issue a16b1095974e071d }} { set msg "MIME-Version: 1.0 Content-Type: text/plain\r \r so plain " set tok [.new {} -string $msg] [$tok body raw] read } "so plain\n" # ------------------------------------------------------------------------- test mime-14.0 {cleanly { hostname argument to parseaddress }} { set parsed [parseaddress hostname fakedomain.fake {Here <h>}] list [llength $parsed] [lindex $parsed 0] } [list 1 [list address [email protected] comment {} domain {} error {} \ friendly Here group {} local h memberP 0 phrase Here \ proper {Here <[email protected]>} route {}]] test mime-14.1 {cleanly { special characters in local part }} { set parsed [parseaddress hostname fakedomain.fake foo<>[email protected]] list [llength $parsed] [lindex $parsed 0] } [list 1 [list address {} comment {} domain {} \ error {expecting mailbox in local-part (found >)} friendly foo group {} \ local {} memberP 0 phrase foo proper {foo <>} route {}]] test mime-14.2 {cleanly { special characters in local part }} { set parsed [parseaddress hostname fakedomain.fake {"foobar"@grill.com}] list [llength $parsed] [lindex $parsed 0] } [list 1 [ list address {"foobar"@grill.com} comment {} domain grill.com error {} \ friendly foobar group {} local {"foobar"} memberP 0 phrase {} \ proper {"foobar"@grill.com} route {}]] # ------------------------------------------------------------------------- test mime-15.0 {cleanly { a multipart/mixed message with an invalid body }} { set msg "MIME-Version: 1.0 Content-Type: multipart/mixed; boundary=\"something\"\r \r so plain " set tok [.new {} -string $msg] $tok header get } [list Content-Type {multipart/mixed {boundary something}}] # ------------------------------------------------------------------------- test mime-16.0 {cleanly { }} { set msg "MIME-Version: 1.0 Content-Type: text/plain\r Content-Disposition: attachment ; param1=\"a parameter value\"; param2*1=\"another param\"; param2*2=\"eter value\" \r \r so plain " set tok [.new {} -string $msg] $tok header get } [list Content-Type {text/plain {}} Content-Disposition [ list attachment [list param1 {a parameter value} \ param2 {another parameter value}]]] set char [encoding convertfrom utf-8 \xE3\x81\xAF] test mime-16.1 {cleanly { }} { set res {} set mime [.new {} -canonical text/plain -string {dawg one}] $mime header set Content-Disposition attachment [list param1 $char] set msg [$mime serialize] lappend res $msg set mime2 [.new {} -string $msg] lappend res [$mime2 header get] return $res } [list "MIME-Version: 1.0\r Message-ID: <c7aa6d4b48aa9fcfe18d9c24adf71de96efbaaf2e261eb1de738ef45f453d1a4@|>\r Content-ID: <086570e97284c5bc5145f32689a5342363b10b64963446293b83930fa8a9fa45@|>\r Content-Type: text/plain\r Content-Disposition: attachment\r ; param1*0*=utf-8''%E3%81%AF\r \r dawg one" \ [list Content-ID {<086570e97284c5bc5145f32689a5342363b10b64963446293b83930fa8a9fa45@|> {}} Content-Type {text/plain {}} \ Message-ID {<c7aa6d4b48aa9fcfe18d9c24adf71de96efbaaf2e261eb1de738ef45f453d1a4@|> {}} \ Content-Disposition [list attachment [list param1 $char]]] ] # ------------------------------------------------------------------------- test mime-13.0 { issue a16b1095974e071d } { set msg "MIME-Version: 1.0 Content-Type: text/plain\r \r so plain " set tok [mime::initialize -string $msg] mime::getbody $tok } "so plain\n" # ------------------------------------------------------------------------- test mime-17.1 {header parsing} {cleanly { set mime [.new {} -string {Content-Type: text/html}] $mime header get Content-Type }} {text/html {}} test mime-17.2 {header parsing} {cleanly { set mime [.new {} -string {Content-Type: text/html; charset=iso-8859-1}] $mime header get Content-Type }} {text/html {charset iso-8859-1}} test mime-17.3 {header parsing} { set mime [.new {} -string {Content-Type: text/html; charset='iso-8859-1'}] $mime header get Content-Type } {text/html {charset 'iso-8859-1'}} test mime-17.4 {header parsing} { set mime [.new {} -string {Content-Type: text/html; charset="iso-8859-1"}] $mime header get Content-Type } {text/html {charset iso-8859-1}} test mime-17.5 {header parsing} -body { set mime [.new {} -string {Content-Type: text/html; charset="iso-8859-1"; ignored}] $mime header get Content-Type } -returnCodes 1 -result {expecting = found end-of-input} test mime-17.6 {header parsing} -body { set mime [.new {} -string {Content-Type: text/html; charset="iso-8859-1"morecrap}] $mime header get Content-Type } -returnCodes 1 -result {expecting = found end-of-input} test mime-17.7 {header parsing} { set mime [.new {} -string {Content-Type: test/test; foo="bar\"baz\""}] $mime header get Content-Type } [list test/test [list foo bar"baz"]] test mime-17.8 {header parsing} { set mime [.new {} -string {Content-Type: test/test; foo=""}] $mime header get Content-Type } {test/test {foo {}}} test mime-17.9 { header supplied by a component message, retrieved by lowercase name } { set mime [.new {} -string {Content-Disposition: form-data; name="field2"}] $mime header get content-disposition } {form-data {name field2}} test mime-17.10 { Content-Type is not automatically added to a subordinate } { set mime [.new {} -string {Content-Disposition: form-data; name="field2"}] $mime header get content-disposition } {form-data {name field2}} test mime-18.1 { non-seekable channel } { set script [list puts -nonewline $message1] set chan [open |[list [info nameofexecutable] <<$script]] tcllib::chan::base .new chan1 $chan set mime [.new {} -spec http -chan chan1] $mime serialize } "Content-Type: text/plain\r \r I'm the message." test mime-19.1 { -http } { set mime [.new {} -spec http -string {}] $mime serialize } "\r " test mime-19.1 { cookie serialization } { set mime [.new {} -spec http -string {}] $mime cookie set one two set res [$mime serialize] $mime .destroy return $res } "Set-Cookie: one=two\r \t; HttpOnly\r \r " test mime-19.2 { cookie serialization } { set mime [.new {} -spec http -string {}] $mime cookie set one two path /three/four set res [$mime serialize] $mime .destroy return $res } "Set-Cookie: one=two\r \t; path=/three/four\r \t; HttpOnly\r \r " testsuiteCleanup set [namespace current]::done 1 return } after 0 [list ::coroutine [info cmdcount]_main [namespace which main]] vwait [namespace current]::done return |
Changes to modules/mime/pkgIndex.tcl.
|
| | | > | > > > | 1 2 3 4 5 6 7 8 9 | if {![package vsatisfies [package provide Tcl] 8.6.9]} {return} package ifneeded smtp 1.4.5 [list source [file join $dir smtp-1.4.tcl]] package ifneeded mime 1.6 [list source [file join $dir mime-1.6.tcl]] if {![package vsatisfies [package provide Tcl] 8.6.9]} {return} package ifneeded smtp 1.5.1 [list source [file join $dir smtp.tcl]] package ifneeded mime 1.7.0 [list source [file join $dir mime.tcl]] package ifneeded {mime qp} 1.7.0 [list source [file join $dir qp.tcl]] |
Added modules/mime/qp.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/env tclsh # ::mime::qp::encode -- # # Tcl version of quote-printable encode # # Arguments: # string The string to quote. # encoded_word Boolean value to determine whether or not encoded words # (RFC 2047) should be handled or not. (optional) # # Results: # The properly quoted string is returned. namespace eval ::mime::qp { namespace ensemble create namespace export decode encode } proc ::mime::qp::encode {string {encoded_word 0} {no_softbreak 0}} { # 8.1+ improved string manipulation routines used. # Replace outlying characters, characters that would normally # be munged by EBCDIC gateways, and special Tcl characters "[\]{} # with =xx sequence if {$encoded_word} { # Special processing for encoded words (RFC 2047) set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF\x09\x5F\x3F]} lappend mapChars { } _ } else { set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} } regsub -all -- $regexp $string {[format =%02X [scan "\\&" %c]]} string # Replace the format commands with their result set string [subst -novariables $string] # soft/hard newlines and other # Funky cases for SMTP compatibility lappend mapChars " \n" =20\n \t\n =09\n \n\.\n =2E\n "\nFrom " "\n=46rom " set string [string map $mapChars $string] # Break long lines - ugh # Implementation of FR #503336 if {$no_softbreak} { set result $string } else { set result {} foreach line [split $string \n] { while {[string length $line] > 72} { set chunk [string range $line 0 72] if {[regexp -- (=|=.)$ $chunk dummy end]} { # Don't break in the middle of a code set len [expr {72 - [string length $end]}] set chunk [string range $line 0 $len] incr len set line [string range $line $len end] } else { set line [string range $line 73 end] } append result $chunk=\n } append result $line\n } # Trim off last \n, since the above code has the side-effect # of adding an extra \n to the encoded string and return the # result. set result [string range $result 0 end-1] } # If the string ends in space or tab, replace with =xx set lastChar [string index $result end] if {$lastChar eq { }} { set result [string replace $result end end =20] } elseif {$lastChar eq "\t"} { set result [string replace $result end end =09] } return $result } # ::mime::qp_decode -- # # Tcl version of quote-printable decode # # Arguments: # string The quoted-printable string to decode. # encoded_word Boolean value to determine whether or not encoded words # (RFC 2047) should be handled or not. (optional) # # Results: # The decoded string is returned. proc ::mime::qp::decode {string {encoded_word 0}} { # 8.1+ improved string manipulation routines used. # Special processing for encoded words (RFC 2047) if {$encoded_word} { # _ == \x20, even if SPACE occupies a different code position set string [string map [list _ \u0020] $string] } # smash the white-space at the ends of lines since that must've been # generated by an MUA. regsub -all -- {[ \t]+\n} $string \n string set string [string trimright $string " \t"] # Protect the backslash for later subst and # smash soft newlines, has to occur after white-space smash # and any encoded word modification. #TODO: codepath not tested set string [string map [list \\ {\\} =\n {}] $string] # Decode specials regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string # process \u unicode mapped chars return [subst -novariables -nocommands $string] } package provide {mime qp} 1.7 |
Added modules/mime/smtp-1.4.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 package require -exact mime 1.6 catch { package require SASL 1.0; # tcllib 1.8 package require SASL::NTLM 1.0; # tcllib 1.8 } # # state variables: # # sd: socket to server # afterID: afterID associated with ::smtp::timer # options: array of user-supplied options # readable: semaphore for vwait # addrs: number of recipients negotiated # error: error during read # line: response read from server # crP: just put a \r in the data # nlP: just put a \n in the data # size: number of octets sent in DATA # namespace eval ::smtp { variable trf 1 variable smtp array set smtp { uid 0 } namespace export sendmessage } if {[catch {package require Trf 2.0}]} { # Trf is not available, but we can live without it as long as the # transform and unstack procs are defined. # Warning! # This is a fragile emulation of the more general calling sequence # that appears to work with this code here. proc transform {args} { upvar state mystate set mystate(size) 1 } proc unstack {channel} { # do nothing return } set ::smtp::trf 0 } # ::smtp::sendmessage -- # # Sends a mime object (containing a message) to some recipients # # Arguments: # part The MIME object containing the message to send # args A list of arguments specifying various options for sending the # message: # -atleastone A boolean specifying whether or not to send the # message at all if any of the recipients are # invalid. A value of false (as defined by # ::smtp::boolean) means that ALL recipients must be # valid in order to send the message. A value of # true means that as long as at least one recipient # is valid, the message will be sent. # -debug A boolean specifying whether or not debugging is # on. If debugging is enabled, status messages are # printed to stderr while trying to send mail. # -queue A boolean specifying whether or not the message # being sent should be queued for later delivery. # -header A single RFC 822 header key and value (as a list), # used to specify to whom to send the message # (To, Cc, Bcc), the "From", etc. # -originator The originator of the message (equivalent to # specifying a From header). # -recipients A string containing recipient e-mail addresses. # NOTE: This option overrides any recipient addresses # specified with -header. # -servers A list of mail servers that could process the # request. # -ports A list of SMTP ports to use for each SMTP server # specified # -client The string to use as our host name for EHLO or HELO # This defaults to 'localhost' or [info hostname] # -maxsecs Maximum number of seconds to allow the SMTP server # to accept the message. If not specified, the default # is 120 seconds. # -usetls A boolean flag. If the server supports it and we # have the package, use TLS to secure the connection. # -tlspolicy A command to call if the TLS negotiation fails for # some reason. Return 'insecure' to continue with # normal SMTP or 'secure' to close the connection and # try another server. # -username These are needed if your SMTP server requires # -password authentication. # # Results: # Message is sent. On success, return "". On failure, throw an # exception with an error code and error message. proc ::smtp::sendmessage {part args} { global errorCode errorInfo # Here are the meanings of the following boolean variables: # aloP -- value of -atleastone option above. # debugP -- value of -debug option above. # origP -- 1 if -originator option was specified, 0 otherwise. # queueP -- value of -queue option above. set aloP 0 set debugP 0 set origP 0 set queueP 0 set maxsecs 120 set originator "" set recipients "" set servers [list localhost] set client "" ;# default is set after options processing set ports [list 25] set tlsP 1 set tlspolicy {} set username {} set password {} array set header "" # lowerL will contain the list of header keys (converted to lower case) # specified with various -header options. mixedL is the mixed-case version # of the list. set lowerL "" set mixedL "" # Parse options (args). if {[expr {[llength $args]%2}]} { # Some option didn't get a value. error "Each option must have a value! Invalid option list: $args" } foreach {option value} $args { switch -- $option { -atleastone {set aloP [boolean $value]} -debug {set debugP [boolean $value]} -queue {set queueP [boolean $value]} -usetls {set tlsP [boolean $value]} -tlspolicy {set tlspolicy $value} -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]} -header { if {[llength $value] != 2} { error "-header expects a key and a value, not $value" } set mixed [lindex $value 0] set lower [string tolower $mixed] set disallowedHdrList \ [list content-type \ content-transfer-encoding \ content-md5 \ mime-version] if {[lsearch -exact $disallowedHdrList $lower] > -1} { error "Content-Type, Content-Transfer-Encoding,\ Content-MD5, and MIME-Version cannot be user-specified." } if {[lsearch -exact $lowerL $lower] < 0} { lappend lowerL $lower lappend mixedL $mixed } lappend header($lower) [lindex $value 1] } -originator { set originator $value if {$originator == ""} { set origP 1 } } -recipients { set recipients $value } -servers { set servers $value } -client { set client $value } -ports { set ports $value } -username { set username $value } -password { set password $value } default { error "unknown option $option" } } } if {[lsearch -glob $lowerL resent-*] >= 0} { set prefixL resent- set prefixM Resent- } else { set prefixL "" set prefixM "" } # Set a bunch of variables whose value will be the real header to be used # in the outbound message (with proper case and prefix). foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} { set lower [string tolower $mixed] # FRINK: nocheck set ${lower}L $prefixL$lower # FRINK: nocheck set ${lower}M $prefixM$mixed } if {$origP} { # -originator was specified with "", so SMTP sender should be marked "". set sender "" } else { # -originator was specified with a value, OR -originator wasn't # specified at all. # If no -originator was provided, get the originator from the "From" # header. If there was no "From" header get it from the username # executing the script. set who "-originator" if {$originator == ""} { if {![info exists header($fromL)]} { set originator $::tcl_platform(user) } else { set originator [join $header($fromL) ,] # Indicate that we're using the From header for the originator. set who $fromM } } # If there's no "From" header, create a From header with the value # of -originator as the value. if {[lsearch -exact $lowerL $fromL] < 0} { lappend lowerL $fromL lappend mixedL $fromM lappend header($fromL) $originator } # ::mime::parseaddress returns a list whose elements are huge key-value # lists with info about the addresses. In this case, we only want one # originator, so we want the length of the main list to be 1. set addrs [::mime::parseaddress $originator] if {[llength $addrs] > 1} { error "too many mailboxes in $who: $originator" } array set aprops {error "invalid address \"$from\""} array set aprops [lindex $addrs 0] if {$aprops(error) != ""} { error "error in $who: $aprops(error)" } # sender = validated originator or the value of the From header. set sender $aprops(address) # If no Sender header has been specified and From is different from # originator, then set the sender header to the From. Otherwise, don't # specify a Sender header. set from [join $header($fromL) ,] if {[lsearch -exact $lowerL $senderL] < 0 && \ [string compare $originator $from]} { if {[info exists aprops]} { unset aprops } array set aprops {error "invalid address \"$from\""} array set aprops [lindex [::mime::parseaddress $from] 0] if {$aprops(error) != ""} { error "error in $fromM: $aprops(error)" } if {[string compare $aprops(address) $sender]} { lappend lowerL $senderL lappend mixedL $senderM lappend header($senderL) $aprops(address) } } } # We're done parsing the arguments. if {$recipients != ""} { set who -recipients } elseif {![info exists header($toL)]} { error "need -header \"$toM ...\"" } else { set recipients [join $header($toL) ,] # Add Cc values to recipients list set who $toM if {[info exists header($ccL)]} { append recipients ,[join $header($ccL) ,] append who /$ccM } set dccInd [lsearch -exact $lowerL $dccL] if {$dccInd >= 0} { # Add Dcc values to recipients list, and get rid of Dcc header # since we don't want to output that. append recipients ,[join $header($dccL) ,] append who /$dccM unset header($dccL) set lowerL [lreplace $lowerL $dccInd $dccInd] set mixedL [lreplace $mixedL $dccInd $dccInd] } } set brecipients "" set bccInd [lsearch -exact $lowerL $bccL] if {$bccInd >= 0} { set bccP 1 # Build valid bcc list and remove bcc element of header array (so that # bcc info won't be sent with mail). foreach addr [::mime::parseaddress [join $header($bccL) ,]] { if {[info exists aprops]} { unset aprops } array set aprops {error "invalid address \"$from\""} array set aprops $addr if {$aprops(error) != ""} { error "error in $bccM: $aprops(error)" } lappend brecipients $aprops(address) } unset header($bccL) set lowerL [lreplace $lowerL $bccInd $bccInd] set mixedL [lreplace $mixedL $bccInd $bccInd] } else { set bccP 0 } # If there are no To headers, add "" to bcc list. WHY?? if {[lsearch -exact $lowerL $toL] < 0} { lappend lowerL $bccL lappend mixedL $bccM lappend header($bccL) "" } # Construct valid recipients list from recipients list. set vrecipients "" foreach addr [::mime::parseaddress $recipients] { if {[info exists aprops]} { unset aprops } array set aprops {error "invalid address \"$from\""} array set aprops $addr if {$aprops(error) != ""} { error "error in $who: $aprops(error)" } lappend vrecipients $aprops(address) } # If there's no date header, get the date from the mime message. Same for # the message-id. if {([lsearch -exact $lowerL $dateL] < 0) \ && ([catch { ::mime::getheader $part $dateL }])} { lappend lowerL $dateL lappend mixedL $dateM lappend header($dateL) [::mime::parsedatetime -now proper] } if {([lsearch -exact $lowerL ${message-idL}] < 0) \ && ([catch { ::mime::getheader $part ${message-idL} }])} { lappend lowerL ${message-idL} lappend mixedL ${message-idM} lappend header(${message-idL}) [::mime::uniqueID] } # Get all the headers from the MIME object and save them so that they can # later be restored. set savedH [::mime::getheader $part] # Take all the headers defined earlier and add them to the MIME message. foreach lower $lowerL mixed $mixedL { foreach value $header($lower) { ::mime::setheader $part $mixed $value -mode append } } if {[string length $client] < 1} { if {![string compare $servers localhost]} { set client localhost } else { set client [info hostname] } } # Create smtp token, which essentially means begin talking to the SMTP # server. set token [initialize -debug $debugP -client $client \ -maxsecs $maxsecs -usetls $tlsP \ -multiple $bccP -queue $queueP \ -servers $servers -ports $ports \ -tlspolicy $tlspolicy \ -username $username -password $password] if {![string match "::smtp::*" $token]} { # An error occurred and $token contains the error info array set respArr $token return -code error $respArr(diagnostic) } set code [catch { sendmessageaux $token $part \ $sender $vrecipients $aloP } \ result] set ecode $errorCode set einfo $errorInfo # Send the message to bcc recipients as a MIME attachment. if {($code == 0) && ($bccP)} { set inner [::mime::initialize -canonical message/rfc822 \ -header [list Content-Description \ "Original Message"] \ -parts [list $part]] set subject "\[$bccM\]" if {[info exists header(subject)]} { append subject " " [lindex $header(subject) 0] } set outer [::mime::initialize \ -canonical multipart/digest \ -header [list From $originator] \ -header [list Bcc ""] \ -header [list Date \ [::mime::parsedatetime -now proper]] \ -header [list Subject $subject] \ -header [list Message-ID [::mime::uniqueID]] \ -header [list Content-Description \ "Blind Carbon Copy"] \ -parts [list $inner]] set code [catch { sendmessageaux $token $outer \ $sender $brecipients \ $aloP } result2] set ecode $errorCode set einfo $errorInfo if {$code == 0} { set result [concat $result $result2] } else { set result $result2 } catch { ::mime::finalize $inner -subordinates none } catch { ::mime::finalize $outer -subordinates none } } # Determine if there was any error in prior operations and set errorcodes # and error messages appropriately. switch -- $code { 0 { set status orderly } 7 { set code 1 array set response $result set result "$response(code): $response(diagnostic)" set status abort } default { set status abort } } # Destroy SMTP token 'cause we're done with it. catch { finalize $token -close $status } # Restore provided MIME object to original state (without the SMTP headers). foreach key [::mime::getheader $part -names] { mime::setheader $part $key "" -mode delete } foreach {key values} $savedH { foreach value $values { ::mime::setheader $part $key $value -mode append } } return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::smtp::sendmessageaux -- # # Sends a mime object (containing a message) to some recipients using an # existing SMTP token. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # part The MIME object containing the message to send. # originator The e-mail address of the entity sending the message, # usually the From clause. # recipients List of e-mail addresses to whom message will be sent. # aloP Boolean "atleastone" setting; see the -atleastone option # in ::smtp::sendmessage for details. # # Results: # Message is sent. On success, return "". On failure, throw an # exception with an error code and error message. proc ::smtp::sendmessageaux {token part originator recipients aloP} { global errorCode errorInfo winit $token $part $originator set goodP 0 set badP 0 set oops "" foreach recipient $recipients { set code [catch { waddr $token $recipient } result] set ecode $errorCode set einfo $errorInfo switch -- $code { 0 { incr goodP } 7 { incr badP array set response $result lappend oops [list $recipient $response(code) \ $response(diagnostic)] } default { return -code $code -errorinfo $einfo -errorcode $ecode $result } } } if {($goodP) && ((!$badP) || ($aloP))} { wtext $token $part } else { catch { talk $token 300 RSET } } return $oops } # ::smtp::initialize -- # # Create an SMTP token and open a connection to the SMTP server. # # Arguments: # args A list of arguments specifying various options for sending the # message: # -debug A boolean specifying whether or not debugging is # on. If debugging is enabled, status messages are # printed to stderr while trying to send mail. # -client Either localhost or the name of the local host. # -multiple Multiple messages will be sent using this token. # -queue A boolean specifying whether or not the message # being sent should be queued for later delivery. # -servers A list of mail servers that could process the # request. # -ports A list of ports on mail servers that could process # the request (one port per server-- defaults to 25). # -usetls A boolean to indicate we will use TLS if possible. # -tlspolicy Command called if TLS setup fails. # -username These provide the authentication information # -password to be used if needed by the SMTP server. # # Results: # On success, return an smtp token. On failure, throw # an exception with an error code and error message. proc ::smtp::initialize {args} { global errorCode errorInfo variable smtp set token [namespace current]::[incr smtp(uid)] # FRINK: nocheck variable $token upvar 0 $token state array set state [list afterID "" options "" readable 0] array set options [list -debug 0 -client localhost -multiple 1 \ -maxsecs 120 -queue 0 -servers localhost \ -ports 25 -usetls 1 -tlspolicy {} \ -username {} -password {}] array set options $args set state(options) [array get options] # Iterate through servers until one accepts a connection (and responds # nicely). set index 0 foreach server $options(-servers) { set state(readable) 0 if {[llength $options(-ports)] >= $index} { set port [lindex $options(-ports) $index] } else { set port 25 } if {$options(-debug)} { puts stderr "Trying $server..." flush stderr } if {[info exists state(sd)]} { unset state(sd) } if {[set code [catch { set state(sd) [socket -async $server $port] fconfigure $state(sd) -blocking off -translation binary fileevent $state(sd) readable [list ::smtp::readable $token] } result]]} { set ecode $errorCode set einfo $errorInfo catch { close $state(sd) } continue } if {[set code [catch { hear $token 600 } result]]} { array set response [list code 400 diagnostic $result] } else { array set response $result } set ecode $errorCode set einfo $errorInfo switch -- $response(code) { 220 { } 421 - default { # 421 - Temporary problem on server catch {close $state(sd)} continue } } set r [initialize_ehlo $token] if {$r != {}} { return $r } incr index } # None of the servers accepted our connection, so close everything up and # return an error. finalize $token -close drop return -code $code -errorinfo $einfo -errorcode $ecode $result } # If we cannot load the tls package, ignore the error proc ::smtp::load_tls {} { set r [catch {package require tls}] if {$r} {set ::errorInfo ""} return $r } proc ::smtp::initialize_ehlo {token} { global errorCode errorInfo upvar einfo einfo upvar ecode ecode upvar code code # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) # Try enhanced SMTP first. if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \ result]]} { array set response [list code 400 diagnostic $result args ""] } else { array set response $result } set ecode $errorCode set einfo $errorInfo if {(500 <= $response(code)) && ($response(code) <= 599)} { if {[set code [catch { talk $token 300 \ "HELO $options(-client)" } \ result]]} { array set response [list code 400 diagnostic $result args ""] } else { array set response $result } set ecode $errorCode set einfo $errorInfo } if {$response(code) == 250} { # Successful response to HELO or EHLO command, so set up queuing # and whatnot and return the token. set state(esmtp) $response(args) if {(!$options(-multiple)) \ && ([lsearch $response(args) ONEX] >= 0)} { catch {smtp::talk $token 300 ONEX} } if {($options(-queue)) \ && ([lsearch $response(args) XQUE] >= 0)} { catch {smtp::talk $token 300 QUED} } # Support STARTTLS extension. # The state(tls) item is used to see if we have already tried this. if {($options(-usetls)) && ![info exists state(tls)] \ && (([lsearch $response(args) STARTTLS] >= 0) || ([lsearch $response(args) TLS] >= 0))} { if {![load_tls]} { set state(tls) 0 if {![catch {smtp::talk $token 300 STARTTLS} resp]} { array set starttls $resp if {$starttls(code) == 220} { fileevent $state(sd) readable {} catch { ::tls::import $state(sd) catch {::tls::handshake $state(sd)} msg set state(tls) 1 } fileevent $state(sd) readable \ [list ::smtp::readable $token] return [initialize_ehlo $token] } else { # Call a TLS client policy proc here # returns secure close and try another server. # returns insecure continue on current socket set policy insecure if {$options(-tlspolicy) != {}} { catch { eval $options(-tlspolicy) \ [list $starttls(code)] \ [list $starttls(diagnostic)] } policy } if {$policy != "insecure"} { set code error set ecode $starttls(code) set einfo $starttls(diagnostic) catch {close $state(sd)} return {} } } } } } # If we have not already tried and the server supports it and we # have a username -- lets try to authenticate. # if {![info exists state(auth)] && [llength [package provide SASL]] != 0 && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 && [string length $options(-username)] > 0 } { # May be AUTH mech or AUTH=mech # We want to use the strongest mechanism that has been offered # and that we support. If we cannot find a mechanism that # succeeds, we will go ahead and try to carry on unauthenticated. # This may still work else we'll get an unauthorised error later. set mechs [string range [lindex $response(args) $andx] 5 end] foreach mech [SASL::mechanisms] { if {[lsearch -exact $mechs $mech] == -1} { continue } if {[catch { Authenticate $token $mech } msg]} { if {$options(-debug)} { puts stderr "AUTH $mech failed: $msg " flush stderr } } if {[info exists state(auth)] && $state(auth)} { if {$state(auth) == 1} { break } else { # After successful AUTH we are supposed to redo # our connection for mechanisms that setup a new # security layer -- these should set state(auth) # greater than 1 fileevent $state(sd) readable \ [list ::smtp::readable $token] return [initialize_ehlo $token] } } } } return $token } else { # Bad response; close the connection and hope the next server # is happier. catch {close $state(sd)} } return {} } proc ::smtp::SASLCallback {token context command args} { upvar #0 $token state upvar #0 $context ctx array set options $state(options) switch -exact -- $command { login { return "" } username { return $options(-username) } password { return $options(-password) } hostname { return [info host] } realm { if {[string equal $ctx(mech) "NTLM"] \ && [info exists ::env(USERDOMAIN)]} { return $::env(USERDOMAIN) } else { return "" } } default { return -code error "error: unsupported SASL information requested" } } } proc ::smtp::Authenticate {token mechanism} { upvar 0 $token state package require base64 set ctx [SASL::new -mechanism $mechanism \ -callback [list [namespace origin SASLCallback] $token]] set state(auth) 0 set result [smtp::talk $token 300 "AUTH $mechanism"] array set response $result while {$response(code) == 334} { # The NTLM initial response is not base64 encoded so handle it. if {[catch {base64::decode $response(diagnostic)} challenge]} { set challenge $response(diagnostic) } SASL::step $ctx $challenge set result [smtp::talk $token 300 \ [base64::encode -maxlen 0 [SASL::response $ctx]]] array set response $result } if {$response(code) == 235} { set state(auth) 1 return $result } else { return -code 7 $result } } # ::smtp::finalize -- # # Deletes an SMTP token by closing the connection to the SMTP server, # cleanup up various state. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # args Optional arguments, where the only useful option is -close, # whose valid values are the following: # orderly Normal successful completion. Close connection and # clear state variables. # abort A connection exists to the SMTP server, but it's in # a weird state and needs to be reset before being # closed. Then clear state variables. # drop No connection exists, so we just need to clean up # state variables. # # Results: # SMTP connection is closed and state variables are cleared. If there's # an error while attempting to close the connection to the SMTP server, # throw an exception with the error code and error message. proc ::smtp::finalize {token args} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state array set options [list -close orderly] array set options $args switch -- $options(-close) { orderly { set code [catch { talk $token 120 QUIT } result] } abort { set code [catch { talk $token 0 RSET talk $token 0 QUIT } result] } drop { set code 0 set result "" } default { error "unknown value for -close $options(-close)" } } set ecode $errorCode set einfo $errorInfo catch { close $state(sd) } if {$state(afterID) != ""} { catch { after cancel $state(afterID) } } foreach name [array names state] { unset state($name) } # FRINK: nocheck unset $token return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::smtp::winit -- # # Send originator info to SMTP server. This occurs after HELO/EHLO # command has completed successfully (in ::smtp::initialize). This function # is called by ::smtp::sendmessageaux. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # part MIME token for the message to be sent. May be used for # handling some SMTP extensions. # originator The e-mail address of the entity sending the message, # usually the From clause. # mode SMTP command specifying the mode of communication. Default # value is MAIL. # # Results: # Originator info is sent and SMTP server's response is returned. If an # error occurs, throw an exception. proc ::smtp::winit {token part originator {mode MAIL}} { # FRINK: nocheck variable $token upvar 0 $token state if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} { error "unknown origination mode $mode" } set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration if {[info exists state(esmtp)] && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { catch { set size [string length [mime::buildmessage $part]] append from " SIZE=$size" } } array set response [set result [talk $token 600 $from]] if {$response(code) == 250} { set state(addrs) 0 return $result } else { return -code 7 $result } } # ::smtp::waddr -- # # Send recipient info to SMTP server. This occurs after originator info # is sent (in ::smtp::winit). This function is called by # ::smtp::sendmessageaux. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # recipient One of the recipients to whom the message should be # delivered. # # Results: # Recipient info is sent and SMTP server's response is returned. If an # error occurs, throw an exception. proc ::smtp::waddr {token recipient} { # FRINK: nocheck variable $token upvar 0 $token state set result [talk $token 3600 "RCPT TO:<$recipient>"] array set response $result switch -- $response(code) { 250 - 251 { incr state(addrs) return $result } default { return -code 7 $result } } } # ::smtp::wtext -- # # Send message to SMTP server. This occurs after recipient info # is sent (in ::smtp::winit). This function is called by # ::smtp::sendmessageaux. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # part The MIME object containing the message to send. # # Results: # MIME message is sent and SMTP server's response is returned. If an # error occurs, throw an exception. proc ::smtp::wtext {token part} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) set result [talk $token 300 DATA] array set response $result if {$response(code) != 354} { return -code 7 $result } if {[catch { wtextaux $token $part } result]} { catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) } return -code 7 [list code 400 diagnostic $result] } set secs $options(-maxsecs) set result [talk $token $secs .] array set response $result switch -- $response(code) { 250 - 251 { return $result } default { return -code 7 $result } } } # ::smtp::wtextaux -- # # Helper function that coordinates writing the MIME message to the socket. # In particular, it stacks the channel leading to the SMTP server, sets up # some file events, sends the message, unstacks the channel, resets the # file events to their original state, and returns. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # part The MIME object containing the message to send. # # Results: # Message is sent. If anything goes wrong, throw an exception. proc ::smtp::wtextaux {token part} { global errorCode errorInfo # FRINK: nocheck variable $token upvar 0 $token state # Workaround a bug with stacking channels on top of TLS. # FRINK: nocheck set trf [set [namespace current]::trf] if {[info exists state(tls)] && $state(tls)} { set trf 0 } flush $state(sd) fileevent $state(sd) readable "" if {$trf} { transform -attach $state(sd) -command [list ::smtp::wdata $token] } else { set state(size) 1 } fileevent $state(sd) readable [list ::smtp::readable $token] # If trf is not available, get the contents of the message, # replace all '.'s that start their own line with '..'s, and # then write the mime body out to the filehandle. Do not forget to # deal with bare LF's here too (SF bug #499242). if {$trf} { set code [catch { ::mime::copymessage $part $state(sd) } result] } else { set code [catch { ::mime::buildmessage $part } result] if {$code == 0} { # Detect and transform bare LF's into proper CR/LF # sequences. while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {} regsub -all -- {\n\.} $result "\n.." result # Fix for bug #827436 - mail data must end with CRLF.CRLF if {[string compare [string index $result end] "\n"] != 0} { append result "\r\n" } set state(size) [string length $result] puts -nonewline $state(sd) $result set result "" } } set ecode $errorCode set einfo $errorInfo flush $state(sd) fileevent $state(sd) readable "" if {$trf} { unstack $state(sd) } fileevent $state(sd) readable [list ::smtp::readable $token] return -code $code -errorinfo $einfo -errorcode $ecode $result } # ::smtp::wdata -- # # This is the custom transform using Trf to do CR/LF translation. If Trf # is not installed on the system, then this function never gets called and # no translation occurs. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # command Trf provided command for manipulating socket data. # buffer Data to be converted. # # Results: # buffer is translated, and state(size) is set. If Trf is not installed # on the system, the transform proc defined at the top of this file sets # state(size) to 1. state(size) is used later to determine a timeout # value. proc ::smtp::wdata {token command buffer} { # FRINK: nocheck variable $token upvar 0 $token state switch -- $command { create/write - clear/write - delete/write { set state(crP) 0 set state(nlP) 1 set state(size) 0 } write { set result "" foreach c [split $buffer ""] { switch -- $c { "." { if {$state(nlP)} { append result . } set state(crP) 0 set state(nlP) 0 } "\r" { set state(crP) 1 set state(nlP) 0 } "\n" { if {!$state(crP)} { append result "\r" } set state(crP) 0 set state(nlP) 1 } default { set state(crP) 0 set state(nlP) 0 } } append result $c } incr state(size) [string length $result] return $result } flush/write { set result "" if {!$state(nlP)} { if {!$state(crP)} { append result "\r" } append result "\n" } incr state(size) [string length $result] return $result } create/read - delete/read { # Bugfix for [#539952] } query/ratio { # Indicator for unseekable channel, # for versions of Trf which ask for # this. return {0 0} } query/maxRead { # No limits on reading bytes from the channel below, for # versions of Trf which ask for this information return -1 } default { # Silently pass all unknown commands. #error "Unknown command \"$command\"" } } return "" } # ::smtp::talk -- # # Sends an SMTP command to a server # # Arguments: # token SMTP token that has an open connection to the SMTP server. # secs Timeout after which command should be aborted. # command Command to send to SMTP server. # # Results: # command is sent and response is returned. If anything goes wrong, throw # an exception. proc ::smtp::talk {token secs command} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) if {$options(-debug)} { puts stderr "--> $command (wait upto $secs seconds)" flush stderr } if {[catch { puts -nonewline $state(sd) "$command\r\n" flush $state(sd) } result]} { return [list code 400 diagnostic $result] } if {$secs == 0} { return "" } return [hear $token $secs] } # ::smtp::hear -- # # Listens for SMTP server's response to some prior command. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # secs Timeout after which we should stop waiting for a response. # # Results: # Response is returned. proc ::smtp::hear {token secs} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) array set response [list args ""] set firstP 1 while {1} { if {$secs >= 0} { ## SF [ 836442 ] timeout with large data ## correction, aotto 031105 - if {$secs > 600} {set secs 600} set state(afterID) [after [expr {$secs*1000}] \ [list ::smtp::timer $token]] } if {!$state(readable)} { vwait ${token}(readable) } # Wait until socket is readable. if {$state(readable) != -1} { catch { after cancel $state(afterID) } set state(afterID) "" } if {$state(readable) < 0} { array set response [list code 400 diagnostic $state(error)] break } set state(readable) 0 if {$options(-debug)} { puts stderr "<-- $state(line)" flush stderr } if {[string length $state(line)] < 3} { array set response \ [list code 500 \ diagnostic "response too short: $state(line)"] break } if {$firstP} { set firstP 0 if {[scan [string range $state(line) 0 2] %d response(code)] \ != 1} { array set response \ [list code 500 \ diagnostic "unrecognizable code: $state(line)"] break } set response(diagnostic) \ [string trim [string range $state(line) 4 end]] } else { lappend response(args) \ [string trim [string range $state(line) 4 end]] } # When status message line ends in -, it means the message is complete. if {[string compare [string index $state(line) 3] -]} { break } } return [array get response] } # ::smtp::readable -- # # Reads a line of data from SMTP server when the socket is readable. This # is the callback of "fileevent readable". # # Arguments: # token SMTP token that has an open connection to the SMTP server. # # Results: # state(line) contains the line of data and state(readable) is reset. # state(readable) gets the following values: # -3 if there's a premature eof, # -2 if reading from socket fails. # 1 if reading from socket was successful proc ::smtp::readable {token} { # FRINK: nocheck variable $token upvar 0 $token state if {[catch { array set options $state(options) }]} { return } set state(line) "" if {[catch { gets $state(sd) state(line) } result]} { set state(readable) -2 set state(error) $result } elseif {$result == -1} { if {[eof $state(sd)]} { set state(readable) -3 set state(error) "premature end-of-file from server" } } else { # If the line ends in \r, remove the \r. if {![string compare [string index $state(line) end] "\r"]} { set state(line) [string range $state(line) 0 end-1] } set state(readable) 1 } if {$state(readable) < 0} { if {$options(-debug)} { puts stderr " ... $state(error) ..." flush stderr } catch { fileevent $state(sd) readable "" } } } # ::smtp::timer -- # # Handles timeout condition on any communication with the SMTP server. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # # Results: # Sets state(readable) to -1 and state(error) to an error message. proc ::smtp::timer {token} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) set state(afterID) "" set state(readable) -1 set state(error) "read from server timed out" if {$options(-debug)} { puts stderr " ... $state(error) ..." flush stderr } } # ::smtp::boolean -- # # Helper function for unifying boolean values to 1 and 0. # # Arguments: # value Some kind of value that represents true or false (i.e. 0, 1, # false, true, no, yes, off, on). # # Results: # Return 1 if the value is true, 0 if false. If the input value is not # one of the above, throw an exception. proc ::smtp::boolean {value} { switch -- [string tolower $value] { 0 - false - no - off { return 0 } 1 - true - yes - on { return 1 } default { error "unknown boolean value: $value" } } } # ------------------------------------------------------------------------- package provide smtp 1.4.5 # ------------------------------------------------------------------------- # Local variables: # indent-tabs-mode: nil # End: |
Changes to modules/mime/smtp.tcl.
1 2 3 4 5 6 7 8 9 10 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # Copyright (c) 2003-2018 Poor Yorick # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 package require mime 1.7- catch { package require SASL 1.0; # tcllib 1.8 package require SASL::NTLM 1.0; # tcllib 1.8 } # |
︙ | ︙ | |||
107 108 109 110 111 112 113 | # -password authentication. # # Results: # Message is sent. On success, return "". On failure, throw an # exception with an error code and error message. proc ::smtp::sendmessage {part args} { | < < | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | # -password authentication. # # Results: # Message is sent. On success, return "". On failure, throw an # exception with an error code and error message. proc ::smtp::sendmessage {part args} { # Here are the meanings of the following boolean variables: # aloP -- value of -atleastone option above. # debugP -- value of -debug option above. # origP -- 1 if -originator option was specified, 0 otherwise. # queueP -- value of -queue option above. set aloP 0 |
︙ | ︙ | |||
304 305 306 307 308 309 310 | lappend header($senderL) $aprops(address) } } } # We're done parsing the arguments. | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | lappend header($senderL) $aprops(address) } } } # We're done parsing the arguments. if {$recipients ne {}} { set who -recipients } elseif {![info exists header($toL)]} { error "need -header \"$toM ...\"" } else { set recipients [join $header($toL) ,] # Add Cc values to recipients list set who $toM |
︙ | ︙ | |||
382 383 384 385 386 387 388 | lappend vrecipients $aprops(address) } # If there's no date header, get the date from the mime message. Same for # the message-id. if {([lsearch -exact $lowerL $dateL] < 0) \ | | | | | > | < < < < < < < | > | | | | > > | < < | | | | | < | | > | | | < | | | | | < < | > | | > > | | | | > > > > > > > | | > | | | > | > > > > > > > > > > > > | 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 | lappend vrecipients $aprops(address) } # If there's no date header, get the date from the mime message. Same for # the message-id. if {([lsearch -exact $lowerL $dateL] < 0) \ && ([catch {$part header get $dateL}])} { lappend lowerL $dateL lappend mixedL $dateM lappend header($dateL) [::mime::datetime -now proper] } if {([lsearch -exact $lowerL ${message-idL}] < 0) \ && ([catch {$part header get ${message-idL}}])} { lappend lowerL ${message-idL} lappend mixedL ${message-idM} lappend header(${message-idL}) [::mime::uniqueID] } # Get all the headers from the MIME object and save them so that they can # later be restored. set savedH [$part header get] # Take all the headers defined earlier and add them to the MIME message. foreach lower $lowerL mixed $mixedL { foreach value $header($lower) { $part header set $mixed $value -mode append } } if {[string length $client] < 1} { if {![string compare $servers localhost]} { set client localhost } else { set client [info hostname] } } # Create smtp token, which essentially means begin talking to the SMTP # server. set token [initialize -debug $debugP -client $client \ -maxsecs $maxsecs -usetls $tlsP \ -multiple $bccP -queue $queueP \ -servers $servers -ports $ports \ -tlspolicy $tlspolicy -tlsimport $tlsimport \ -username $username -password $password] if {![string match ::smtp::* $token]} { # An error occurred and $token contains the error info array set respArr $token return -code error $respArr(diagnostic) } set code1 [catch { sendmessageaux $token $part $sender $vrecipients $aloP } cres1 copts1] lappend results $code1 $cres1 $copts1 if {!$code1 && $bccP} { # Send the message to bcc recipients as a MIME attachment. set inner [::mime::.new {} -canonical message/rfc822 \ -headers [list Content-Description \ {Original Message}] \ -parts [list $part]] set subject "\[$bccM\]" if {[info exists header(subject)]} { append subject " " [lindex $header(subject) 0] } set outer [::mime::.new {} \ -canonical multipart/digest \ -headers [list \ From [list $originator {}] \ Bcc Date [::mime::datetime -now proper] \ Subject $subject \ Message-ID [::mime::uniqueID] \ Content-Description {Blind Carbon Copy} \ -parts [list $inner]]] set code2 [catch { sendmessageaux $token $outer $sender $brecipients $aloP } cres2 copts2] lappend results $code2 $cres2 $copts2 catch {$inner .destroy -subordinates none} catch {$outer .destroy -subordinates none} } # Determine if there was any error in prior operations and set errorcodes # and error messages appropriately. foreach {code cres copts} $results { # handle just the first one switch -- $code { 0 { set status orderly } 7 { dict set copts -code 1 set status abort break } default { set status abort break } } } # Destroy SMTP token 'cause we're done with it. set code3 [catch {finalize $token -close $status} cres3 copts3] if {$code3 && !$code} { lassign [list $cres3 $copts3] cres copts } # Restore provided MIME object to original state (without the SMTP # headers). To avoid an incorect attempt to set a read-only header like # "Content-Type', the only original headers that were saved were those that # were later modified. foreach {key value} $origheaders { mime::setheader $part $key {} -mode delete ::mime::setheader $part [dict get orignames $key] $value -mode append } foreach {key val} [$part header get] { $part header set $key "" -mode delete } foreach {key value} $savedH { $part header set $key {*}$value -mode append } return -options $copts $cres } # ::smtp::sendmessageaux -- # # Sends a mime object (containing a message) to some recipients using an |
︙ | ︙ | |||
901 902 903 904 905 906 907 | # # Results: # SMTP connection is closed and state variables are cleared. If there's # an error while attempting to close the connection to the SMTP server, # throw an exception with the error code and error message. proc ::smtp::finalize {token args} { | < > | | | | | | | | | | | | | | | | | | < | | | | > | | | | | | | | | < | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 | # # Results: # SMTP connection is closed and state variables are cleared. If there's # an error while attempting to close the connection to the SMTP server, # throw an exception with the error code and error message. proc ::smtp::finalize {token args} { # FRINK: nocheck variable $token upvar 0 $token state array set options [list -close orderly] array set options $args try { switch -- $options(-close) { orderly { set code [catch { talk $token 120 QUIT } result] } abort { set code [catch { talk $token 0 RSET talk $token 0 QUIT } result] } drop { set code 0 set result "" } default { error "unknown value for -close $options(-close)" } } } finally { if {$state(sd) in [chan names]} { close $state(sd) } if {$state(afterID) ne {}} { after cancel $state(afterID) } foreach name [array names state] { unset state($name) } # FRINK: nocheck unset $token } } # ::smtp::winit -- # # Send originator info to SMTP server. This occurs after HELO/EHLO # command has completed successfully (in ::smtp::initialize). This function # is called by ::smtp::sendmessageaux. |
︙ | ︙ | |||
982 983 984 985 986 987 988 | set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration if {[info exists state(esmtp)] && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { catch { | | | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 | set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration if {[info exists state(esmtp)] && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { catch { set size [string length [$part serialize]] append from " SIZE=$size" } } array set response [set result [talk $token 600 $from]] if {$response(code) == 250} { |
︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 | # replace all '.'s that start their own line with '..'s, and # then write the mime body out to the filehandle. Do not forget to # deal with bare LF's here too (SF bug #499242). if {$trf} { set code [catch { ::mime::copymessage $part $state(sd) } result] } else { | | | 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 | # replace all '.'s that start their own line with '..'s, and # then write the mime body out to the filehandle. Do not forget to # deal with bare LF's here too (SF bug #499242). if {$trf} { set code [catch { ::mime::copymessage $part $state(sd) } result] } else { set code [catch {$part serialize} result] if {$code == 0} { # Detect and transform bare LF's into proper CR/LF # sequences. while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {} regsub -all -- {\n\.} $result "\n.." result |
︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 | array set options $state(options) if {$options(-debug)} { puts stderr "--> $command (wait upto $secs seconds)" flush stderr } | > | | > | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 | array set options $state(options) if {$options(-debug)} { puts stderr "--> $command (wait upto $secs seconds)" flush stderr } if {[catch { puts -nonewline $state(sd) $command\r\n flush $state(sd) } result] } { return [list code 400 diagnostic $result] } if {$secs == 0} { return "" } |
︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 | proc ::smtp::hear {token secs} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) | | | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 | proc ::smtp::hear {token secs} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) array set response [list args {}] set firstP 1 while 1 { if {$secs >= 0} { ## SF [ 836442 ] timeout with large data ## correction, aotto 031105 - if {$secs > 600} {set secs 600} set state(afterID) [after [expr {$secs*1000}] \ [list ::smtp::timer $token]] } |
︙ | ︙ |
Added modules/mime/smtp.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/env tclsh # copyright 2018 Poor Yorick source [file join \ [file dirname [file dirname [file dirname [ file normalize [info script]/...]]]]/devtools/testutilities.tcl] testsNeedTcl 8.6.9 testsNeedTcltest 2 testing { useLocal smtp.tcl smtp } package require nettool package require smtpd variable port [nettool::allocate_port 1025] smtpd::start localhost $port proc accept msg { variable result set headers [$msg header get] lappend result [lsort [dict keys $headers]] lappend result [$msg header get From] return } proc main {} { variable done variable result test smtp-1.1 {} -body { variable port smtpd::configure -deliverMIME [namespace which accept] set msg [mime::.new {} -canonical text/plain \ -string {a door is ajar}] set res [smtp::sendmessage $msg -ports $port -originator Slawkenbergius -recipients {[email protected]}] lappend result $res return $result } -cleanup { unset result } -result [list \ {Bcc Content-ID Content-Type Date From Message-ID Received Return-Path} {Slawkenbergius {}} {} ] testsuiteCleanup set done 1 return } after 0 [list coroutine [info cmdcount]_main [namespace which main]] vwait [namespace current]::done |
Changes to modules/multiplexer/multiplexer.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal multiplexer.tcl multiplexer } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/namespacex/namespacex.man.
︙ | ︙ | |||
108 109 110 111 112 113 114 | as given by [arg cmdname]. [para] Additional pairs of [arg cmdname] / [arg newname] arguments may also be specified. [call [cmd {::namespacex info allchildren}] [arg namespace]] | | | | | | | < < < < < < > > > > > | | | | | | | | | < | | | 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 170 171 172 | as given by [arg cmdname]. [para] Additional pairs of [arg cmdname] / [arg newname] arguments may also be specified. [call [cmd {::namespacex info allchildren}] [arg namespace]] Returns a list containing the names of all child namespaces in the specified [arg namespace] and its children. The names are all fully qualified. [call [cmd {::namespacex info allvars}] [arg namespace]] Returns a list containing the names of all variables in the specified [arg namespace] and its children. The names are all relative to [arg namespace], and [emph not] fully qualified. [call [cmd {::namespacex info vars}] [arg namespace] [opt [arg pattern]]] Returns a list containing the names of all variables in the specified [arg namespace]. If the [arg pattern] argument is specified, then only variables matching [arg pattern] are returned. Matching is determined using the same rules as for [cmd {string match}]. [call [cmd {::namespacex normalize}] [arg namespace]] Returns the absolute name of [arg namespace], which is resolved relative to the namespace of the caller, with all unneeded colon characters removed. [call [cmd {::namespacex state get}] [arg namespace]] Returns a dictionary holding the names and values of all variables in the specified [arg namespace] and its child namespaces. [para] Note that the names are all relative to [arg namespace], and [emph not] fully qualified. [call [cmd {::namespacex state set}] [arg namespace] [arg dict]] Takes a dictionary holding the names and values for a set of variables and replaces the current state of the specified [arg namespace] and its child namespaces with this state. The result of the command is the empty string. [call [cmd {::namespacex state drop}] [arg namespace]] Unsets all variables in the specified [arg namespace] and its child namespaces. The result of the command is the empty string. [call [cmd {::namespacex strip}] [arg namespace] [arg namespaces]] Each item in [arg namespaces] must be the absolute normalized name of a child namespace of [arg prefix]. Returns the corresponding list of relative names of child namespaces. [list_end] [vset CATEGORY namespacex] [include ../common-text/feedback.inc] [manpage_end] |
Changes to modules/namespacex/namespacex.tcl.
︙ | ︙ | |||
20 21 22 23 24 25 26 | # i.e. before 8.6. if {![llength [info commands try]]} { package require try ; # tcllib } namespace eval ::namespacex { | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | # i.e. before 8.6. if {![llength [info commands try]]} { package require try ; # tcllib } namespace eval ::namespacex { namespace export add hook import info normalize strip state namespace ensemble create namespace eval hook { namespace export add proc on next namespace ensemble create # add - hook a command prefix into the chain of unknown handlers for a |
︙ | ︙ | |||
212 213 214 215 216 217 218 | namespace delete $tmp } finally { namespace eval $from [list ::namespace export -clear {*}$orig] } return } | > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > | > | > < > | < < < < < < < < < < < < > > > | > | > > | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 | namespace delete $tmp } finally { namespace eval $from [list ::namespace export -clear {*}$orig] } return } proc ::namespacex::import {from args} { set upns [uplevel 1 {namespace current}] if {![string match ::* $from]} { set from $upns::$from[set from {}] } set orig [namespace eval $from {namespace export}] try { namespace eval $from {namespace export *} set tmp [namespace current]::[::info cmdcount] namespace eval $tmp [list ::namespace import ${from}::*] if {[llength $args] == 1} { lappend args [lindex $args 0] } dict size $args foreach {old new} $args { rename ${tmp}::$old ${upns}::$new } namespace delete $tmp } finally { namespace eval $from [list ::namespace export -clear {*}$orig] } return } proc ::namespacex::info::allvars ns { set ns [uplevel 1 [list [namespace parent] normalize $ns]] ::set result [::info vars ${ns}::*] foreach cns [allchildren $ns] { lappend result {*}[::info vars ${cns}::*] } return [[namespace parent] strip $ns $result] } proc ::namespacex::info::allchildren ns { set ns [uplevel 1 [list [namespace parent] normalize $ns]] ::set result [list] foreach cns [::namespace children $ns] { lappend result {*}[allchildren $cns] lappend result $cns } return $result } proc ::namespacex::info::vars {ns {pattern *}} { set ns [uplevel 1 [list [namespace parent] normalize $ns]] return [[namespace parent] strip $ns [::info vars ${ns}::$pattern]] } # this implementation avoids string operations proc ::namespacex::normalize ns { if {[uplevel 1 [list ::namespace exists $ns]]} { return [uplevel 1 [list namespace eval $ns {::namespace current}]] } if {![string match ::* $ns]} { set ns [uplevel 1 {::namespace current}]::$ns } regsub {::+} $ns :: ns return $ns } proc ::namespacex::strip {ns itemlist} { set n [string length $ns] if {$ns ne {::}} { incr n 2 } set result {} foreach i $itemlist { lappend result [string range $i $n end] } return $result } # # ## ### ##### ######## ############# ###################### ## Implementation :: State - Visible API proc ::namespacex::state::drop ns { ::set ns [uplevel 1 [list [namespace parent] normalize $ns]] namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]] return } proc ::namespacex::state::get ns { ::set ns [uplevel 1 [list [namespace parent] normalize $ns]] ::set result {} foreach v [::namespacex info allvars $ns] { namespace upvar $ns $v value lappend result $v $value } return $result } proc ::namespacex::state::set {ns state} { ::set ns [uplevel 1 [list [namespace parent] normalize $ns]] # Inlined 'state drop'. namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]] namespace eval $ns [list variable {*}$state] return } # # ## ### ##### ######## ############# ###################### ## Ready package provide namespacex 0.2 |
Changes to modules/namespacex/namespacex.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | testing { useLocal namespacex.tcl namespacex } # ------------------------------------------------------------------------- ## helpers | > > | | | | | | | | | | | | | | | | | | | | | | | | | > | | > > > | | > > > | | > > > > > > > | > > > > > > > > | | | | < < > < < < < | > | > | | > > > > > > > | | > > > > | | > | > > > | | < > | | | | > > > | > > | | < < < | > > > > | | | > > > > > | | | > | > > > | > | > > > > > | | | > | > > > > > > | | > > > > | > | > | > | | | > | | < < < | > > | > > > | | > > | > > | < < | > > > > | > | | | | > > | | < | | > > > > | | > > > > > | > > | > | > | | | > | | < > | > | | > > > > > | | | | | > > > > > > > | > | | | > > > | | | | > | > > > > | > | | > > > > > | | > > > > > | | < > > | | | | | | | | > | | > > > | > > | > > | > | | | | | > | > > | > | | | > | > > > > > > > > > > | > | | | | > | | | > | | | | | | | > | | | | | | | > | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | < < < < < < < < < < < < < < < | | | | | | > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | testing { useLocal namespacex.tcl namespacex } # ------------------------------------------------------------------------- ## helpers namespace eval Q { proc ns_setup {} { namespace eval X { namespace eval A {} namespace eval B { namespace eval D {} } namespace eval C {} } } proc ns2_setup {} { namespace eval X::Y { variable vXa 1 variable vXb aleph namespace eval B { variable vB 3 } } } proc ns3_setup {} { namespace eval X { namespace eval B { variable vB mjolnir } } } # ------------------------------------------------------------------------- test namespacex-info-allchildren-1.0 {namespacex info allchildren, wrong\#args} -body { namespacex info allchildren } -returnCodes error -result {wrong # args: should be "namespacex info allchildren ns"} test namespacex-info-allchildren-1.1 {namespacex info allchildren, wrong\#args} -body { namespacex info allchildren N X } -returnCodes error -result {wrong # args: should be "namespacex info allchildren ns"} test namespacex-info-allchildren-2.0.0 {namespacex info allchildren} -setup { ns_setup } -body { lsort -dict [namespacex strip [namespace current] [namespacex info allchildren X]] } -cleanup { namespace delete X } -result {X::A X::B X::B::D X::C} test namespacex-info-allchildren-2.0.1 {namespacex info allchildren} -setup { ns_setup } -body { lsort -dict [namespacex strip [namespace current] [namespacex info allchildren X]] } -cleanup { namespace delete X } -result {X::A X::B X::B::D X::C} # ------------------------------------------------------------------------- test namespacex-info-vars-1.0 {namespacex info vars, wrong\#args} -body { namespacex info vars } -returnCodes error -result {wrong # args: should be "namespacex info vars ns ?pattern?"} test namespacex-info-vars-1.1 {namespacex info vars, wrong\#args} -body { namespacex info vars N P X } -returnCodes error -result {wrong # args: should be "namespacex info vars ns ?pattern?"} test namespacex-info-vars-2.0 {namespacex info vars} -setup { ns2_setup } -body { lsort -dict [namespacex info vars X::::Y] } -cleanup { namespace delete X } -result {vXa vXb} test namespacex-info-vars-2.1 {namespacex info vars} -setup { namespace eval X {} } -body { lsort -dict [namespacex info vars X] } -cleanup { namespace delete X } -result {} test namespacex-info-vars-2.2 {namespacex info vars} -setup { ns3_setup } -body { lsort -dict [namespacex info vars X] } -cleanup { namespace delete X } -result {} # ------------------------------------------------------------------------- test namespacex-info-allvars-1.0 {namespacex info allvars, wrong\#args} -body { namespacex info allvars } -returnCodes error -result {wrong # args: should be "namespacex info allvars ns"} test namespacex-info-allvars-1.1 {namespacex info allvars, wrong\#args} -body { namespacex info allvars N X } -returnCodes error -result {wrong # args: should be "namespacex info allvars ns"} test namespacex-info-allvars-2.0.0 {namespacex info allvars} -setup { ns2_setup } -body { lsort -dict [namespacex info allvars X::::Y] } -cleanup { namespace delete X } -result {B::vB vXa vXb} test namespacex-info-allvars-2.0.1 {namespacex info allvars} -setup { ns2_setup } -body { lsort -dict [namespacex info allvars X::Y] } -cleanup { namespace delete X } -result {B::vB vXa vXb} test namespacex-info-allvars-2.1.0 {namespacex info allvars} -setup { namespace eval X {} } -body { lsort -dict [namespacex info allvars X] } -cleanup { namespace delete X } -result {} test namespacex-info-allvars-2.1.1 {namespacex info allvars} -setup { namespace eval X {} } -body { lsort -dict [namespacex info allvars X] } -cleanup { namespace delete X } -result {} test namespacex-info-allvars-2.2.0 {namespacex info allvars} -setup { ns3_setup } -body { lsort -dict [namespacex info allvars X] } -cleanup { namespace delete X } -result {B::vB} test namespacex-info-allvars-2.2.1 {namespacex info allvars} -setup { ns3_setup } -body { lsort -dict [namespacex info allvars X] } -cleanup { namespace delete X } -result {B::vB} # ------------------------------------------------------------------------- test namespacex-state-get-1.0 {namespacex state get, wrong\#args} -body { namespacex state get } -returnCodes error -result {wrong # args: should be "namespacex state get ns"} test namespacex-state-get-1.1 {namespacex state get, wrong\#args} -body { namespacex state get N X } -returnCodes error -result {wrong # args: should be "namespacex state get ns"} test namespacex-state-get-2.0.0 {namespacex state get} -setup { ns2_setup } -body { dictsort [namespacex state get X::Y] } -cleanup { namespace delete X } -result {B::vB 3 vXa 1 vXb aleph} test namespacex-state-get-2.0.1 {namespacex state get} -setup { ns2_setup } -body { dictsort [namespacex state get X::Y] } -cleanup { namespace delete X } -result {B::vB 3 vXa 1 vXb aleph} test namespacex-state-get-2.1.0 {namespacex state get} -setup { namespace eval ::X {} } -body { dictsort [namespacex state get ::X] } -cleanup { namespace delete ::X } -result {} test namespacex-state-get-2.1.1 {namespacex state get} -setup { namespace eval X {} } -body { dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} test namespacex-state-get-2.2.0 {namespacex state get} -setup { ns3_setup } -body { dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {B::vB mjolnir} test namespacex-state-get-2.2.1 {namespacex state get} -setup { ns3_setup } -body { dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {B::vB mjolnir} # ------------------------------------------------------------------------- test namespacex-state-drop-1.0 {namespacex state drop, wrong\#args} -body { namespacex state drop } -returnCodes error -result {wrong # args: should be "namespacex state drop ns"} test namespacex-state-drop-1.1 {namespacex state drop, wrong\#args} -body { namespacex state drop N X } -returnCodes error -result {wrong # args: should be "namespacex state drop ns"} test namespacex-state-drop-2.0.0 {namespacex state drop} -setup { ns2_setup } -body { namespacex state drop X dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} test namespacex-state-drop-2.0.1 {namespacex state drop} -setup { ns2_setup } -body { namespacex state drop X dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} test namespacex-state-drop-2.1.0 {namespacex state drop} -setup { namespace eval X {} } -body { namespacex state drop X dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} test namespacex-state-drop-2.1.1 {namespacex state drop} -setup { namespace eval X {} } -body { namespacex state drop X dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} test namespacex-state-drop-2.2.0 {namespacex state drop} -setup { ns3_setup } -body { namespacex state drop X dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} test namespacex-state-drop-2.2.1 {namespacex state drop} -setup { ns3_setup } -body { namespacex state drop X dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {} # ------------------------------------------------------------------------- test namespacex-state-set-1.0 {namespacex state set, wrong\#args} -body { namespacex state set } -returnCodes error -result {wrong # args: should be "namespacex state set ns state"} test namespacex-state-set-1.1 {namespacex state set, wrong\#args} -body { namespacex state set N } -returnCodes error -result {wrong # args: should be "namespacex state set ns state"} test namespacex-state-set-1.2 {namespacex state set, wrong\#args} -body { namespacex state set N S X } -returnCodes error -result {wrong # args: should be "namespacex state set ns state"} test namespacex-state-set-2.0.0 {namespacex state set} -setup { ns2_setup set ST [namespacex state get X::Y] ns3_setup } -body { namespacex state set X::Y $ST dictsort [namespacex state get X::Y] } -cleanup { namespace delete X } -result {B::vB 3 vXa 1 vXb aleph} test namespacex-state-set-2.0.1 {namespacex state set} -setup { ns2_setup set ST [namespacex state get X::Y] ns3_setup } -body { namespacex state set X::Y $ST dictsort [namespacex state get X::Y] } -cleanup { namespace delete X::Y } -result {B::vB 3 vXa 1 vXb aleph} test namespacex-info-allchildren-2.0.2 {namespacex info allchildren, relative to non-global} -setup { ns_setup ::Q } -body { namespace eval ::Q { lsort -dict [namespacex info allchildren X] } } -cleanup { namespace delete ::Q } -result {::Q::X::A ::Q::X::B ::Q::X::B::D ::Q::X::C} test namespacex-state-set-2.1.0 {namespacex state set} -setup { ns3_setup set ST [namespacex state get X] ns2_setup } -body { namespacex state set X $ST dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {B::vB mjolnir} ## info vars test namespacex-info-vars-1.0 {namespacex info vars, wrong\#args, not enough} -body { namespacex info vars } -returnCodes error -result {wrong # args: should be "namespacex info vars ns ?pattern?"} test namespacex-info-vars-1.1 {namespacex info vars, wrong\#args, too many} -body { namespacex info vars N P X } -returnCodes error -result {wrong # args: should be "namespacex info vars ns ?pattern?"} test namespacex-info-vars-2.0.0 {namespacex info vars, fqn} -setup { ns2_setup } -body { lsort -dict [namespacex info vars ::X] } -cleanup { namespace delete ::X } -result {vXa vXb} test namespacex-info-vars-2.0.1 {namespacex info vars, relative to global} -setup { ns2_setup } -body { lsort -dict [namespacex info vars X] } -cleanup { namespace delete ::X } -result {vXa vXb} test namespacex-info-vars-2.0.2 {namespacex info vars, relative to non-global} -setup { ns2_setup ::Q } -body { namespace eval ::Q { lsort -dict [namespacex info vars X] } } -cleanup { namespace delete ::Q } -result {vXa vXb} test namespacex-state-set-2.1.1 {namespacex state set} -setup { ns3_setup set ST [namespacex state get X] ns2_setup } -body { namespacex state set X $ST dictsort [namespacex state get X] } -cleanup { namespace delete X } -result {B::vB mjolnir} # ------------------------------------------------------------------------- testsuiteCleanup # Local variables: # mode: tcl # indent-tabs-mode: nil # End: } |
Added modules/ncgi/ncgi-1.4.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 | # ncgi.tcl # # Basic support for CGI programs # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2012 Richard Hipp, Andreas Kupries # Copyright (c) 2013-2014 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Please note that Don Libes' has a "cgi.tcl" that implements version 1.0 # of the cgi package. That implementation provides a bunch of cgi_ procedures # (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for # generating HTML. In contract, the package provided here is primarly # concerned with processing input to CGI programs. I have tried to mirror his # API's where possible. So, ncgi::input is equivalent to cgi_input, and so # on. There are also some different APIs for accessing values (ncgi::list, # ncgi::parse and ncgi::value come to mind) # Note, I use the term "query data" to refer to the data that is passed in # to a CGI program. Typically this comes from a Form in an HTML browser. # The query data is composed of names and values, and the names can be # repeated. The names and values are encoded, and this module takes care # of decoding them. # We use newer string routines package require Tcl 8.4 package require fileutil ; # Required by importFile. package require uri package provide ncgi 1.4.3 namespace eval ::ncgi { # "query" holds the raw query (i.e., form) data # This is treated as a cache, too, so you can call ncgi::query more than # once variable query # This is the content-type which affects how the query is parsed variable contenttype # value is an array of parsed query data. Each array element is a list # of values, and the array index is the form element name. # See the differences among ncgi::parse, ncgi::input, ncgi::value # and ncgi::valuelist for the various approaches to handling these values. variable value # This lists the names that appear in the query data variable varlist # This holds the URL coresponding to the current request # This does not include the server name. variable urlStub # This flags compatibility with Don Libes cgi.tcl when dealing with # form values that appear more than once. This bit gets flipped when # you use the ncgi::input procedure to parse inputs. variable listRestrict 0 # This is the set of cookies that are pending for output variable cookieOutput # Support for x-www-urlencoded character mapping # The spec says: "non-alphanumeric characters are replaced by '%HH'" variable i variable c variable map for {set i 1} {$i <= 256} {incr i} { set c [format %c $i] if {![string match \[a-zA-Z0-9\] $c]} { set map($c) %[format %.2X $i] } } # These are handled specially array set map { " " + \n %0D%0A } # Map of transient files variable _tmpfiles array set _tmpfiles {} # I don't like importing, but this makes everything show up in # pkgIndex.tcl namespace export reset urlStub query type decode encode namespace export nvlist parse input value valueList names namespace export setValue setValueList setDefaultValue setDefaultValueList namespace export empty import importAll importFile redirect header namespace export parseMimeValue multipart cookie setCookie } # ::ncgi::reset # # This resets the state of the CGI input processor. This is primarily # used for tests, although it is also designed so that TclHttpd can # call this with the current query data # so the ncgi package can be shared among TclHttpd and CGI scripts. # # DO NOT CALL this in a standard cgi environment if you have not # yet processed the query data, which will not be used after a # call to ncgi::reset is made. Instead, just call ncgi::parse # # Arguments: # newquery The query data to be used instead of external CGI. # newtype The raw content type. # # Side Effects: # Resets the cached query data and wipes any environment variables # associated with CGI inputs (like QUERY_STRING) proc ::ncgi::reset {args} { global env variable _tmpfiles variable query variable contenttype variable cookieOutput # array unset _tmpfiles -- Not a Tcl 8.2 idiom unset _tmpfiles ; array set _tmpfiles {} set cookieOutput {} if {[llength $args] == 0} { # We use and test args here so we can detect the # difference between empty query data and a full reset. if {[info exists query]} { unset query } if {[info exists contenttype]} { unset contenttype } } else { set query [lindex $args 0] set contenttype [lindex $args 1] } } # ::ncgi::urlStub # # Set or return the URL associated with the current page. # This is for use by TclHttpd to override the default value # that otherwise comes from the CGI environment # # Arguments: # url (option) The url of the page, not counting the server name. # If not specified, the current urlStub is returned # # Side Effects: # May affects future calls to ncgi::urlStub proc ::ncgi::urlStub {{url {}}} { global env variable urlStub if {[string length $url]} { set urlStub $url return "" } elseif {[info exists urlStub]} { return $urlStub } elseif {[info exists env(SCRIPT_NAME)]} { set urlStub $env(SCRIPT_NAME) return $urlStub } else { return "" } } # ::ncgi::query # # This reads the query data from the appropriate location, which depends # on if it is a POST or GET request. # # Arguments: # none # # Results: # The raw query data. proc ::ncgi::query {} { global env variable query if {[info exists query]} { # This ensures you can call ncgi::query more than once, # and that you can use it with ncgi::reset return $query } set query "" if {[info exists env(REQUEST_METHOD)]} { if {$env(REQUEST_METHOD) == "GET"} { if {[info exists env(QUERY_STRING)]} { set query $env(QUERY_STRING) } } elseif {$env(REQUEST_METHOD) == "POST"} { if {[info exists env(CONTENT_LENGTH)] && [string length $env(CONTENT_LENGTH)] != 0} { ## added by Steve Cassidy to try to fix binary file upload fconfigure stdin -translation binary -encoding binary set query [read stdin $env(CONTENT_LENGTH)] } } } return $query } # ::ncgi::type # # This returns the content type of the query data. # # Arguments: # none # # Results: # The content type of the query data. proc ::ncgi::type {} { global env variable contenttype if {![info exists contenttype]} { if {[info exists env(CONTENT_TYPE)]} { set contenttype $env(CONTENT_TYPE) } else { return "" } } return $contenttype } # ::ncgi::decode # # This decodes data in www-url-encoded format. # # Arguments: # An encoded value # # Results: # The decoded value if {[package vsatisfies [package present Tcl] 8.6]} { # 8.6+, use 'binary decode hex' proc ::ncgi::DecodeHex {hex} { return [binary decode hex $hex] } } else { # 8.4+. More complex way of handling the hex conversion. proc ::ncgi::DecodeHex {hex} { return [binary format H* $hex] } } proc ::ncgi::decode {str} { # rewrite "+" back to space # protect \ from quoting another '\' set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str] # prepare to process all %-escapes regsub -all -- {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \ $str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str regsub -all -- {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \ $str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str # process \u unicode mapped chars return [subst -novar $str] } # ::ncgi::encode # # This encodes data in www-url-encoded format. # # Arguments: # A string # # Results: # The encoded value proc ::ncgi::encode {string} { variable map # 1 leave alphanumerics characters alone # 2 Convert every other character to an array lookup # 3 Escape constructs that are "special" to the tcl parser # 4 "subst" the result, doing all the array substitutions regsub -all -- \[^a-zA-Z0-9\] $string {$map(&)} string # This quotes cases like $map([) or $map($) => $map(\[) ... regsub -all -- {[][{})\\]\)} $string {\\&} string return [subst -nocommand $string] } # ::ncgi::names # # This parses the query data and returns a list of the names found therein. # # Note: If you use ncgi::setValue or ncgi::setDefaultValue, this # names procedure doesn't see the effect of that. # # Arguments: # none # # Results: # A list of names proc ::ncgi::names {} { array set names {} foreach {name val} [nvlist] { if {![string equal $name "anonymous"]} { set names($name) 1 } } return [array names names] } # ::ncgi::nvlist # # This parses the query data and returns it as a name, value list # # Note: If you use ncgi::setValue or ncgi::setDefaultValue, this # nvlist procedure doesn't see the effect of that. # # Arguments: # none # # Results: # An alternating list of names and values proc ::ncgi::nvlist {} { set query [query] set type [type] switch -glob -- $type { "" - text/xml* - application/x-www-form-urlencoded* - application/x-www-urlencoded* { set result {} # Any whitespace at the beginning or end of urlencoded data is not # considered to be part of that data, so we trim it off. One special # case in which post data is preceded by a \n occurs when posting # with HTTPS in Netscape. foreach {x} [split [string trim $query] &] { # Turns out you might not get an = sign, # especially with <isindex> forms. set pos [string first = $x] set len [string length $x] if { $pos>=0 } { if { $pos == 0 } { # if the = is at the beginning ... if { $len>1 } { # ... and there is something to the right ... set varname anonymous set val [string range $x 1 end] } else { # ... otherwise, all we have is an = set varname anonymous set val "" } } elseif { $pos==[expr {$len-1}] } { # if the = is at the end ... set varname [string range $x 0 [expr {$pos-1}]] set val "" } else { set varname [string range $x 0 [expr {$pos-1}]] set val [string range $x [expr {$pos+1}] end] } } else { # no = was found ... set varname anonymous set val $x } lappend result [decode $varname] [decode $val] } return $result } multipart/* { return [multipart $type $query] } default { return -code error "Unknown Content-Type: $type" } } } # ::ncgi::parse # # The parses the query data and stores it into an array for later retrieval. # You should use the ncgi::value or ncgi::valueList procedures to get those # values, or you are allowed to access the ncgi::value array directly. # # Note - all values have a level of list structure associated with them # to allow for multiple values for a given form element (e.g., a checkbox) # # Arguments: # none # # Results: # A list of names of the query values proc ::ncgi::parse {} { variable value variable listRestrict 0 variable varlist {} if {[info exists value]} { unset value } foreach {name val} [nvlist] { if {![info exists value($name)]} { lappend varlist $name } lappend value($name) $val } return $varlist } # ::ncgi::input # # Like ncgi::parse, but with Don Libes cgi.tcl semantics. # Form elements must have a trailing "List" in their name to be # listified, otherwise this raises errors if an element appears twice. # # Arguments: # fakeinput See ncgi::reset # fakecookie The raw cookie string to use when testing. # # Results: # The list of element names in the form proc ::ncgi::input {{fakeinput {}} {fakecookie {}}} { variable value variable varlist {} variable listRestrict 1 if {[info exists value]} { unset value } if {[string length $fakeinput]} { ncgi::reset $fakeinput } foreach {name val} [nvlist] { set exists [info exists value($name)] if {!$exists} { lappend varlist $name } if {[string match "*List" $name]} { # Accumulate a list of values for this name lappend value($name) $val } elseif {$exists} { error "Multiple definitions of $name encountered in input.\ If you're trying to do this intentionally (such as with select),\ the variable must have a \"List\" suffix." } else { # Capture value with no list structure set value($name) $val } } return $varlist } # ::ncgi::value # # Return the value of a named query element, or the empty string if # it was not not specified. This only returns the first value of # associated with the name. If you want them all (like all values # of a checkbox), use ncgi::valueList # # Arguments: # key The name of the query element # default The value to return if the value is not present # # Results: # The first value of the named element, or the default proc ::ncgi::value {key {default {}}} { variable value variable listRestrict variable contenttype if {[info exists value($key)]} { if {$listRestrict} { # ::ncgi::input was called, and it already figured out if the # user wants list structure or not. set val $value($key) } else { # Undo the level of list structure done by ncgi::parse set val [lindex $value($key) 0] } if {[string match multipart/* [type]]} { # Drop the meta-data information associated with each part set val [lindex $val 1] } return $val } else { return $default } } # ::ncgi::valueList # # Return all the values of a named query element as a list, or # the empty list if it was not not specified. This always returns # lists - if you do not want the extra level of listification, use # ncgi::value instead. # # Arguments: # key The name of the query element # # Results: # The first value of the named element, or "" proc ::ncgi::valueList {key {default {}}} { variable value if {[info exists value($key)]} { return $value($key) } else { return $default } } # ::ncgi::setValue # # Jam a new value into the CGI environment. This is handy for preliminary # processing that does data validation and cleanup. # # Arguments: # key The name of the query element # value This is a single value, and this procedure wraps it up in a list # for compatibility with the ncgi::value array usage. If you # want a list of values, use ngci::setValueList # # # Side Effects: # Alters the ncgi::value and possibly the ncgi::valueList variables proc ::ncgi::setValue {key value} { variable listRestrict if {$listRestrict} { ncgi::setValueList $key $value } else { ncgi::setValueList $key [list $value] } } # ::ncgi::setValueList # # Jam a list of new values into the CGI environment. # # Arguments: # key The name of the query element # valuelist This is a list of values, e.g., for checkbox or multiple # selections sets. # # Side Effects: # Alters the ncgi::value and possibly the ncgi::valueList variables proc ::ncgi::setValueList {key valuelist} { variable value variable varlist if {![info exists value($key)]} { lappend varlist $key } # This if statement is a workaround for another hack in # ::ncgi::value that treats multipart form data # differently. if {[string match multipart/* [type]]} { set value($key) [list [list {} [join $valuelist]]] } else { set value($key) $valuelist } return "" } # ::ncgi::setDefaultValue # # Set a new value into the CGI environment if there is not already one there. # # Arguments: # key The name of the query element # value This is a single value, and this procedure wraps it up in a list # for compatibility with the ncgi::value array usage. # # # Side Effects: # Alters the ncgi::value and possibly the ncgi::valueList variables proc ::ncgi::setDefaultValue {key value} { ncgi::setDefaultValueList $key [list $value] } # ::ncgi::setDefaultValueList # # Jam a list of new values into the CGI environment if the CGI value # is not already defined. # # Arguments: # key The name of the query element # valuelist This is a list of values, e.g., for checkbox or multiple # selections sets. # # Side Effects: # Alters the ncgi::value and possibly the ncgi::valueList variables proc ::ncgi::setDefaultValueList {key valuelist} { variable value if {![info exists value($key)]} { ncgi::setValueList $key $valuelist return "" } else { return "" } } # ::ncgi::exists -- # # Return false if the CGI variable doesn't exist. # # Arguments: # name Name of the CGI variable # # Results: # 0 if the variable doesn't exist proc ::ncgi::exists {var} { variable value return [info exists value($var)] } # ::ncgi::empty -- # # Return true if the CGI variable doesn't exist or is an empty string # # Arguments: # name Name of the CGI variable # # Results: # 1 if the variable doesn't exist or has the empty value proc ::ncgi::empty {name} { return [expr {[string length [string trim [value $name]]] == 0}] } # ::ncgi::import # # Map a CGI input into a Tcl variable. This creates a Tcl variable in # the callers scope that has the value of the CGI input. An alternate # name for the Tcl variable can be specified. # # Arguments: # cginame The name of the form element # tclname If present, an alternate name for the Tcl variable, # otherwise it is the same as the form element name proc ::ncgi::import {cginame {tclname {}}} { if {[string length $tclname]} { upvar 1 $tclname var } else { upvar 1 $cginame var } set var [value $cginame] } # ::ncgi::importAll # # Map a CGI input into a Tcl variable. This creates a Tcl variable in # the callers scope for every CGI value, or just for those named values. # # Arguments: # args A list of form element names. If this is empty, # then all form value are imported. proc ::ncgi::importAll {args} { variable varlist if {[llength $args] == 0} { set args $varlist } foreach cginame $args { upvar 1 $cginame var set var [value $cginame] } } # ::ncgi::redirect # # Generate a redirect by returning a header that has a Location: field. # If the URL is not absolute, this automatically qualifies it to # the current server # # Arguments: # url The url to which to redirect # # Side Effects: # Outputs a redirect header proc ::ncgi::redirect {url} { global env if {![regexp -- {^[^:]+://} $url]} { # The url is relative (no protocol/server spec in it), so # here we create a canonical URL. # request_uri The current URL used when dealing with relative URLs. # proto http or https # server The server, which we are careful to match with the # current one in base Basic Authentication is being used. # port This is set if it is not the default port. if {[info exists env(REQUEST_URI)]} { # Not all servers have the leading protocol spec #regsub -- {^https?://[^/]*/} $env(REQUEST_URI) / request_uri array set u [uri::split $env(REQUEST_URI)] set request_uri /$u(path) unset u } elseif {[info exists env(SCRIPT_NAME)]} { set request_uri $env(SCRIPT_NAME) } else { set request_uri / } set port "" if {[info exists env(HTTPS)] && $env(HTTPS) == "on"} { set proto https if {$env(SERVER_PORT) != 443} { set port :$env(SERVER_PORT) } } else { set proto http if {$env(SERVER_PORT) != 80} { set port :$env(SERVER_PORT) } } # Pick the server from REQUEST_URI so it matches the current # URL. Otherwise use SERVER_NAME. These could be different, e.g., # "pop.scriptics.com" vs. "pop" if {[info exists env(REQUEST_URI)]} { # Not all servers have the leading protocol spec if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} { set server $env(SERVER_NAME) } } else { set server $env(SERVER_NAME) } if {[string match /* $url]} { set url $proto://$server$port$url } else { regexp -- {^(.*/)[^/]*$} $request_uri match dirname set url $proto://$server$port$dirname$url } } ncgi::header text/html Location $url puts "Please go to <a href=\"$url\">$url</a>" } # ncgi:header # # Output the Content-Type header. # # Arguments: # type The MIME content type # args Additional name, value pairs to specifiy output headers # # Side Effects: # Outputs a normal header proc ::ncgi::header {{type text/html} args} { variable cookieOutput puts "Content-Type: $type" foreach {n v} $args { puts "$n: $v" } if {[info exists cookieOutput]} { foreach line $cookieOutput { puts "Set-Cookie: $line" } } puts "" flush stdout } # ::ncgi::parseMimeValue # # Parse a MIME header value, which has the form # value; param=value; param2="value2"; param3='value3' # # Arguments: # value The mime header value. This does not include the mime # header field name, but everything after it. # # Results: # A two-element list, the first is the primary value, # the second is in turn a name-value list corresponding to the # parameters. Given the above example, the return value is # { # value # {param value param2 value param3 value3} # } proc ::ncgi::parseMimeValue {value} { set parts [split $value \;] set results [list [string trim [lindex $parts 0]]] set paramList [list] foreach sub [lrange $parts 1 end] { if {[regexp -- {([^=]+)=(.+)} $sub match key val]} { set key [string trim [string tolower $key]] set val [string trim $val] # Allow single as well as double quotes if {[regexp -- {^["']} $val quote]} { ;# need a " for balance if {[regexp -- ^${quote}(\[^$quote\]*)$quote $val x val2]} { # Trim quotes and any extra crap after close quote set val $val2 } } lappend paramList $key $val } } if {[llength $paramList]} { lappend results $paramList } return $results } # ::ncgi::multipart # # This parses multipart form data. # Based on work by Steve Ball for TclHttpd, but re-written to use # string first with an offset to iterate through the data instead # of using a regsub/subst combo. # # Arguments: # type The Content-Type, because we need boundary options # query The raw multipart query data # # Results: # An alternating list of names and values # In this case, the value is a two element list: # headers, which in turn is a list names and values # content, which is the main value of the element # The header name/value pairs come primarily from the MIME headers # like Content-Type that appear in each part. However, the # Content-Disposition header is handled specially. It has several # parameters like "name" and "filename" that are important, so they # are promoted to to the same level as Content-Type. Otherwise, # if a header like Content-Type has parameters, they appear as a list # after the primary value of the header. For example, if the # part has these two headers: # # Content-Disposition: form-data; name="Foo"; filename="/a/b/C.txt" # Content-Type: text/html; charset="iso-8859-1"; mumble='extra' # # Then the header list will have this structure: # { # content-disposition form-data # name Foo # filename /a/b/C.txt # content-type {text/html {charset iso-8859-1 mumble extra}} # } # Note that the header names are mapped to all lowercase. You can # use "array set" on the header list to easily find things like the # filename or content-type. You should always use [lindex $value 0] # to account for values that have parameters, like the content-type # example above. Finally, not that if the value has a second element, # which are the parameters, you can "array set" that as well. # proc ::ncgi::multipart {type query} { set parsedType [parseMimeValue $type] if {![string match multipart/* [lindex $parsedType 0]]} { return -code error "Not a multipart Content-Type: [lindex $parsedType 0]" } array set options [lindex $parsedType 1] if {![info exists options(boundary)]} { return -code error "No boundary given for multipart document" } set boundary $options(boundary) # The query data is typically read in binary mode, which preserves # the \r\n sequence from a Windows-based browser. # Also, binary data may contain \r\n sequences. if {[string match "*$boundary\r\n*" $query]} { set lineDelim "\r\n" # puts "DELIM" } else { set lineDelim "\n" # puts "NO" } # Iterate over the boundary string and chop into parts set len [string length $query] # [string length $lineDelim]+2 is for "$lineDelim--" set blen [expr {[string length $lineDelim] + 2 + \ [string length $boundary]}] set first 1 set results [list] set offset 0 # Ensuring the query data starts # with a newline makes the string first test simpler if {[string first $lineDelim $query 0]!=0} { set query $lineDelim$query } while {[set offset [string first $lineDelim--$boundary $query $offset]] \ >= 0} { if {!$first} { lappend results $formName [list $headers \ [string range $query $off2 [expr {$offset -1}]]] } else { set first 0 } incr offset $blen # Check for the ending boundary, which is signaled by --$boundary-- if {[string equal "--" \ [string range $query $offset [expr {$offset + 1}]]]} { break } # Split headers out from content # The headers become a nested list structure: # {header-name { # value { # paramname paramvalue ... } # } # } set off2 [string first "$lineDelim$lineDelim" $query $offset] set headers [list] set formName "" foreach line [split [string range $query $offset $off2] $lineDelim] { if {[regexp -- {([^: ]+):(.*)$} $line x hdrname value]} { set hdrname [string tolower $hdrname] set valueList [parseMimeValue $value] if {[string equal $hdrname "content-disposition"]} { # Promote Conent-Disposition parameters up to headers, # and look for the "name" that identifies the form element lappend headers $hdrname [lindex $valueList 0] foreach {n v} [lindex $valueList 1] { lappend headers $n $v if {[string equal $n "name"]} { set formName $v } } } else { lappend headers $hdrname $valueList } } } if {$off2 > 0} { # +[string length "$lineDelim$lineDelim"] for the # $lineDelim$lineDelim incr off2 [string length "$lineDelim$lineDelim"] set offset $off2 } else { break } } return $results } # ::ncgi::importFile -- # # get information about a file upload field # # Arguments: # cmd one of '-server' '-client' '-type' '-data' # var cgi variable name for the file field # filename filename to write to for -server # Results: # -server returns the name of the file on the server: side effect # is that the file gets stored on the server and the # script is responsible for deleting/moving the file # -client returns the name of the file sent from the client # -type returns the mime type of the file # -data returns the contents of the file proc ::ncgi::importFile {cmd var {filename {}}} { set vlist [valueList $var] array set fileinfo [lindex [lindex $vlist 0] 0] set contents [lindex [lindex $vlist 0] 1] switch -exact -- $cmd { -server { ## take care not to write it out more than once variable _tmpfiles if {![info exists _tmpfiles($var)]} { if {$filename != {}} { ## use supplied filename set _tmpfiles($var) $filename } else { ## create a tmp file set _tmpfiles($var) [::fileutil::tempfile ncgi] } # write out the data only if it's not been done already if {[catch {open $_tmpfiles($var) w} h]} { error "Can't open temporary file in ncgi::importFile ($h)" } fconfigure $h -translation binary -encoding binary puts -nonewline $h $contents close $h } return $_tmpfiles($var) } -client { if {![info exists fileinfo(filename)]} {return {}} return $fileinfo(filename) } -type { if {![info exists fileinfo(content-type)]} {return {}} return $fileinfo(content-type) } -data { return $contents } default { error "Unknown subcommand to ncgi::import_file: $cmd" } } } # ::ncgi::cookie # # Return a *list* of cookie values, if present, else "" # It is possible for multiple cookies with the same key # to be present, so we return a list. # # Arguments: # cookie The name of the cookie (the key) # # Results: # A list of values for the cookie proc ::ncgi::cookie {cookie} { global env set result "" if {[info exists env(HTTP_COOKIE)]} { foreach pair [split $env(HTTP_COOKIE) \;] { foreach {key value} [split [string trim $pair] =] { break ;# lassign } if {[string compare $cookie $key] == 0} { lappend result $value } } } return $result } # ::ncgi::setCookie # # Set a return cookie. You must call this before you call # ncgi::header or ncgi::redirect # # Arguments: # args Name value pairs, where the names are: # -name Cookie name # -value Cookie value # -path Path restriction # -domain domain restriction # -expires Time restriction # # Side Effects: # Formats and stores the Set-Cookie header for the reply. proc ::ncgi::setCookie {args} { variable cookieOutput array set opt $args set line "$opt(-name)=$opt(-value) ;" foreach extra {path domain} { if {[info exists opt(-$extra)]} { append line " $extra=$opt(-$extra) ;" } } if {[info exists opt(-expires)]} { switch -glob -- $opt(-expires) { *GMT { set expires $opt(-expires) } default { set expires [clock format [clock scan $opt(-expires)] \ -format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1] } } append line " expires=$expires ;" } if {[info exists opt(-secure)]} { append line " secure " } lappend cookieOutput $line } |
Added modules/ncgi/ncgi-1.4.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 | # -*- tcl -*- # Tests for the cgi module. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions # # RCS: @(#) $Id: ncgi.test,v 1.28 2012/05/03 17:56:07 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2 testsNeedTcl 8.4 testsNeedTcltest 2 testing { useLocal ncgi-1.4.tcl ncgi } # ------------------------------------------------------------------------- set sub_ap $auto_path lappend sub_ap $::tcltest::testsDirectory set ncgiFile [localPath ncgi-1.4.tcl] set futlFile [tcllibPath fileutil/fileutil.tcl] set cmdlFile [tcllibPath cmdline/cmdline.tcl] # ------------------------------------------------------------------------- test ncgi-1.1 {ncgi::reset} { ncgi::reset list [info exist ncgi::query] [info exist ncgi::contenttype] } {0 0} test ncgi-1.2 {ncgi::reset} { ncgi::reset query=reset list $ncgi::query $ncgi::contenttype } {query=reset {}} test ncgi-1.3 {ncgi::reset} { ncgi::reset query=reset text/plain list $ncgi::query $ncgi::contenttype } {query=reset text/plain} test ncgi-2.1 {ncgi::query fake query data} { ncgi::reset "fake=query" ncgi::query set ncgi::query } "fake=query" test ncgi-2.2 {ncgi::query GET} { ncgi::reset set env(REQUEST_METHOD) GET set env(QUERY_STRING) name=value ncgi::query set ncgi::query } "name=value" test ncgi-2.3 {ncgi::query HEAD} { ncgi::reset set env(REQUEST_METHOD) HEAD catch {unset env(QUERY_STRING)} ncgi::query set ncgi::query } "" test ncgi-2.4 {ncgi::query POST} { ncgi::reset catch {unset env(QUERY_STRING)} set env(REQUEST_METHOD) POST set env(CONTENT_LENGTH) 10 makeFile [format { set auto_path {%s} source {%s} source {%s} source {%s} ncgi::query puts $ncgi::query exit } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 ; # {} set f [open "|[list $::tcltest::tcltest test1]" r+] puts $f "name=value" flush $f gets $f line close $f removeFile test1 set line } "name=value" test ncgi-2.5 {ncgi::test} { ncgi::reset set env(CONTENT_TYPE) text/html ncgi::type } text/html test ncgi-2.6 {ncgi::test} { ncgi::reset foo=bar text/plain set env(CONTENT_TYPE) text/html ncgi::type } text/plain test ncgi-3.1 {ncgi::decode} { ncgi::decode abcdef0123 } abcdef0123 test ncgi-3.2 {ncgi::decode} { ncgi::decode {[abc]def$0123\x} } {[abc]def$0123\x} test ncgi-3.3 {ncgi::decode} { ncgi::decode {[a%25c]def$01%7E3\x%3D} } {[a%c]def$01~3\x=} test ncgi-3.4 {ncgi::decode} { ncgi::decode {hello+world} } {hello world} test ncgi-3.5 {ncgi::decode} { ncgi::decode {aik%C5%ABloa} } "aik\u016Bloa" ; # u+macron test ncgi-3.6 {ncgi::decode} { ncgi::decode {paran%C3%A1} } "paran\u00E1" ; # a+acute test ncgi-3.7 {ncgi::decode, bug 3601995} { ncgi::decode {%C4%85} } "\u0105" ; # a+ogonek test ncgi-3.8 {ncgi::decode, bug 3601995} { ncgi::decode {%E2%80%A0} } "\u2020" ; # dagger test ncgi-3.9 {ncgi::decode, bug 3601995} { ncgi::decode {%E2%A0%90} } "\u2810" ; # a braille pattern test ncgi-3.10 {ncgi::decode, bug 3601995} { ncgi::decode {%E2%B1} } "%E2%B1" ; # missing byte trailing %A0, do not accept/decode, pass through. test ncgi-4.1 {ncgi::encode} { ncgi::encode abcdef0123 } abcdef0123 test ncgi-4.2 {ncgi::encode} { ncgi::encode "\[abc\]def\$0123\\x" } {%5Babc%5Ddef%240123%5Cx} test ncgi-4.3 {ncgi::encode} { ncgi::encode {hello world} } {hello+world} test ncgi-4.4 {ncgi::encode} { ncgi::encode "hello\nworld\r\tbar" } {hello%0D%0Aworld%0D%09bar} test ncgi-5.1 {ncgi::nvlist} { ncgi::reset "name=hello+world&name2=%7ewelch" ncgi::nvlist } {name {hello world} name2 ~welch} test ncgi-5.2 {ncgi::nvlist} { ncgi::reset "name=&name2" application/x-www-urlencoded ncgi::nvlist } {name {} anonymous name2} test ncgi-5.3 {ncgi::nvlist} { ncgi::reset "name=&name2" application/x-www-form-urlencoded ncgi::nvlist } {name {} anonymous name2} test ncgi-5.4 {ncgi::nvlist} { ncgi::reset "name=&name2" application/xyzzy set code [catch ncgi::nvlist err] list $code $err } {1 {Unknown Content-Type: application/xyzzy}} # multipart tests at the end because I'm too lazy to renumber the tests test ncgi-6.1 {ncgi::parse, anonymous values} { ncgi::reset "name=&name2" ncgi::parse } {name anonymous} test ncgi-6.2 {ncgi::parse, no list restrictions} { ncgi::reset "name=value&name=value2" ncgi::parse } {name} test ncgi-7.1 {ncgi::input} { ncgi::reset catch {unset env(REQUEST_METHOD)} ncgi::input "name=value&name2=value2" } {name name2} test ncgi-7.2 {ncgi::input} { ncgi::reset "nameList=value1+stuff&nameList=value2+more" ncgi::input set ncgi::value(nameList) } {{value1 stuff} {value2 more}} test ncgi-7.3 {ncgi::input} { ncgi::reset "name=value&name=value2" catch {ncgi::input} err set err } {Multiple definitions of name encountered in input. If you're trying to do this intentionally (such as with select), the variable must have a "List" suffix.} test ncgi-8.1 {ncgi::value} { ncgi::reset "nameList=val+ue&nameList=value2" ncgi::input ncgi::value nameList } {{val ue} value2} test ncgi-8.2 {ncgi::value} { ncgi::reset "name=val+ue&name=value2" ncgi::parse ncgi::value name } {val ue} test ncgi-8.3 {ncgi::value} { ncgi::reset "name=val+ue&name=value2" ncgi::parse ncgi::value noname } {} test ncgi-9.1 {ncgi::valueList} { ncgi::reset "name=val+ue&name=value2" ncgi::parse ncgi::valueList name } {{val ue} value2} test ncgi-9.2 {ncgi::valueList} { ncgi::reset "name=val+ue&name=value2" ncgi::parse ncgi::valueList noname } {} test ncgi-10.1 {ncgi::import} { ncgi::reset "nameList=val+ue&nameList=value2" ncgi::input ncgi::import nameList set nameList } {{val ue} value2} test ncgi-10.2 {ncgi::import} { ncgi::reset "nameList=val+ue&nameList=value2" ncgi::input ncgi::import nameList myx set myx } {{val ue} value2} test ncgi-10.3 {ncgi::import} { ncgi::reset "nameList=val+ue&nameList=value2" ncgi::input ncgi::import noname set noname } {} test ncgi-10.4 {ncgi::importAll} { ncgi::reset "name1=val+ue&name2=value2" catch {unset name1} catch {unset name2} ncgi::parse ncgi::importAll list $name1 $name2 } {{val ue} value2} test ncgi-10.5 {ncgi::importAll} { ncgi::reset "name1=val+ue&name2=value2" catch {unset name1} catch {unset name2} catch {unset name3} ncgi::parse ncgi::importAll name2 name3 list [info exist name1] $name2 $name3 } {0 value2 {}} set URL http://www.tcltk.com/index.html test ncgi-11.1 {ncgi::redirect} { set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL\n\nPlease go to <a href=\"$URL\">$URL</a>\n" set URL /elsewhere/foo.html set URL2 http://www/elsewhere/foo.html test ncgi-11.2 {ncgi::redirect} { set env(REQUEST_URI) http://www/cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::setCookie -name CookieName -value 12345 ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\nSet-Cookie: CookieName=12345 ;\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 http://www.scriptics.com/cgi-bin/foo.html test ncgi-11.3 {ncgi::redirect} { set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 http://www.scriptics.com/cgi-bin/foo.html test ncgi-11.4 {ncgi::redirect} { set env(REQUEST_URI) /cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 http://www.scriptics.com:8000/cgi-bin/foo.html test ncgi-11.5 {ncgi::redirect} { set env(REQUEST_URI) /cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 8000 makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 https://www.scriptics.com/cgi-bin/foo.html test ncgi-11.6 {ncgi::redirect} { set env(REQUEST_URI) /cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 443 set env(HTTPS) "on" makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL login.tcl set URL2 https://foo.com/cgi-bin/login.tcl test ncgi-11.7 {ncgi::redirect} { set env(REQUEST_URI) https://foo.com/cgi-bin/view.tcl?path=/a/b/c set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) foo.com set env(SERVER_PORT) 443 set env(HTTPS) "on" makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::redirect %s } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" test ncgi-12.1 {ncgi::header} { makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::header } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\n\n" test ncgi-12.2 {ncgi::header} { makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::header text/plain } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/plain\n\n" test ncgi-12.3 {ncgi::header} { makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::header text/html X-Comment "This is a test" } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nX-Comment: This is a test\n\n" test ncgi-12.4 {ncgi::header} { makeFile [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi::setCookie -name Name -value {The+Value} ncgi::header } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 set f [open "|[list $::tcltest::tcltest test1]" r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nSet-Cookie: Name=The+Value ;\n\n" test ncgi-13.1 {ncgi::parseMimeValue} { ncgi::parseMimeValue text/html } text/html test ncgi-13.2 {ncgi::parseMimeValue} { ncgi::parseMimeValue "text/html; charset=iso-8859-1" } {text/html {charset iso-8859-1}} test ncgi-13.3 {ncgi::parseMimeValue} { ncgi::parseMimeValue "text/html; charset='iso-8859-1'" } {text/html {charset iso-8859-1}} test ncgi-13.4 {ncgi::parseMimeValue} { ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"" } {text/html {charset iso-8859-1}} test ncgi-13.5 {ncgi::parseMimeValue} { ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"; ignored" } {text/html {charset iso-8859-1}} test ncgi-13.6 {ncgi::parseMimeValue} { ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"morecrap" } {text/html {charset iso-8859-1}} test ncgi-14.1 {ncgi::multipart} { catch {ncgi::multipart "application/x-www-urlencoded" name=val+ue} err set err } {Not a multipart Content-Type: application/x-www-urlencoded} test ncgi-14.2 {ncgi::multipart} { catch {ncgi::multipart "multipart/form-data" {}} err set err } {No boundary given for multipart document} test ncgi-14.3 {ncgi::multipart} { set in [open [file join [file dirname [info script]] formdata.txt]] set X [read $in] close $in foreach line [split $X \n] { if {[string length $line] == 0} { break } if {[regexp {^Content-Type: (.*)$} $line x type]} { break } } regsub ".*?\n\n" $X {} X ncgi::reset $X $type ncgi::multipart $type $X } {field1 {{content-disposition form-data name field1} value} field2 {{content-disposition form-data name field2} {another value}} the_file_name {{content-disposition form-data name the_file_name filename {C:\Program Files\Netscape\Communicator\Program\nareadme.htm} content-type text/html} { <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> }}} test ncgi-14.4 {ncgi::multipart} { set in [open [file join [file dirname [info script]] formdata.txt]] set X [read $in] close $in foreach line [split $X \n] { if {[string length $line] == 0} { break } if {[regexp {^Content-Type: (.*)$} $line x type]} { break } } regsub ".*?\n\n" $X {} X ncgi::reset $X $type ncgi::parse list [ncgi::value field1] [ncgi::value field2] [ncgi::value the_file_name] } {value {another value} { <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> }} test ncgi-14.6 {ncgi::multipart setValue} { set in [open [file join [file dirname [info script]] formdata.txt]] set X [read $in] close $in foreach line [split $X \n] { if {[string length $line] == 0} { break } if {[regexp {^Content-Type: (.*)$} $line x type]} { break } } regsub ".*?\n\n" $X {} X ncgi::reset $X $type ncgi::parse ncgi::setValue userval1 foo ncgi::setValue userval2 "a b" list [ncgi::value field1] [ncgi::value field2] [ncgi::value userval1] [ncgi::value userval2] [ncgi::value the_file_name] } {value {another value} foo {a b} { <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> }} test ncgi-15.1 {ncgi::setValue} { ncgi::reset "nameList=val+ue&nameList=value2" ncgi::input ncgi::setValue foo 1 ncgi::setValue bar "a b" list [ncgi::value nameList] [ncgi::value foo] [ncgi::value bar] } {{{val ue} value2} 1 {a b}} ## ------------ tests for binary content and file upload ---------------- ## some utility procedures to generate content set form_boundary {17661509020136} proc genformcontent_type {} { global form_boundary return "multipart/form-data; boundary=\"$form_boundary\"" } proc genformdata {bcontent} { global form_boundary proc genformdatapart {name cd value} { global form_boundary return "--$form_boundary\nContent-Disposition: form-data; name=\"$name\"$cd\n\n$value\n" } set a [genformdatapart field1 "" {value}] set b [genformdatapart field2 "" {another value}] set c [genformdatapart the_file_name "; filename=\"C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm\"\nContent-Type: text/html" $bcontent] return "$a$b$c--$form_boundary--\n" } set binary_content "\r \r <center><h1>\r Netscape Address Book Sync for Palm Pilot\r User Guide\r </h1></center>\r \r " test ncgi-14.5 {ncgi::multipart--check binary file} { global binary_content set X [genformdata $binary_content] ncgi::reset $X [genformcontent_type] ncgi::parse set content [ncgi::value the_file_name] list [ncgi::value field1] [ncgi::value field2] $content } [list value {another value} $binary_content] test ncgi-16.1 {ncgi::importFile} { global binary_content set X [genformdata $binary_content] ncgi::reset $X [genformcontent_type] ncgi::parse ncgi::importFile -client the_file_name } "C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm" test ncgi-16.2 {ncgi::importFile - content type} { global binary_content set X [genformdata $binary_content] ncgi::reset $X [genformcontent_type] ncgi::parse ncgi::importFile -type the_file_name } text/html test ncgi-16.3 {ncgi::importFile -- file contents} { global binary_content set X [genformdata $binary_content] ncgi::reset $X [genformcontent_type] ncgi::parse ncgi::importFile -data the_file_name } $binary_content test ncgi-16.4 {ncgi::importFile -- save file} { global binary_content set X [genformdata $binary_content] ncgi::reset $X [genformcontent_type] ncgi::parse set localfile [ncgi::importFile -server the_file_name] # get the contents of the local file to verify set in [open $localfile] fconfigure $in -translation binary set content [read $in] close $in file delete $localfile set content } $binary_content test ncgi-16.5 {ncgi::importFile -- save file, given name} { global binary_content set X [genformdata $binary_content] ncgi::reset $X [genformcontent_type] ncgi::parse set localfile [ncgi::importFile -server the_file_name fofo] # get the contents of the local file to verify set in [open $localfile] fconfigure $in -translation binary set content [read $in] close $in file delete $localfile set content } $binary_content test ncgi-16.6 {ncgi::importFile -- bad input} { set X "bad multipart data" ncgi::reset $X [genformcontent_type] ncgi::parse ncgi::importFile -client the_file_name } {} test ncgi-17.1 {ncgi::names} { ncgi::reset "name=hello+world&name2=%7ewelch" ncgi::names } {name name2} test ncgi-17.2 {ncgi::names} { ncgi::reset "name=&name2" application/x-www-urlencoded ncgi::names } {name} test ncgi-17.3 {ncgi::names} { ncgi::reset "name=&name2" application/x-www-form-urlencoded ncgi::names } {name} test ncgi-17.4 {ncgi::names} { ncgi::reset "name=&name2" application/xyzzy set code [catch ncgi::names err] list $code $err } {1 {Unknown Content-Type: application/xyzzy}} # ------------------------------------------------------------------------- testsuiteCleanup return |
Changes to modules/ncgi/ncgi.man.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | [vset VERSION 1.4.4] [manpage_begin ncgi n [vset VERSION]] [see_also html] [keywords CGI] [keywords cookie] [keywords form] [keywords html] [comment {-*- tcl -*- doctools manpage}] [moddesc {CGI Support}] [titledesc {Procedures to manipulate CGI values.}] [category {CGI programming}] [require Tcl 8.4] [require ncgi [opt [vset VERSION]]] [description] [para] | > | | < > | | | | > | > > > > | > > < < < < < < < | > < | < | < > | > | > | | | > | > | > | > | | | > | < < > | | | | | | < | > | | < | > | | | | | | | < > > < | > > | | > | | | > < < < < > > | < | | | > > | > | > > | < < > | | < < < < > | < < < | | | | | | > > | > | | > | > > > | > | < < | < | | | | | | | > | < < < < < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | [vset VERSION 1.4.4] [manpage_begin ncgi n [vset VERSION]] [see_also html] [keywords CGI] [keywords cookie] [keywords form] [keywords html] [comment {-*- tcl -*- doctools manpage}] [copyright {2018 Poor Yorick}] [moddesc {CGI Support}] [titledesc {Procedures to manipulate CGI values.}] [category {CGI programming}] [require Tcl 8.4] [require ncgi [opt [vset VERSION]]] [description] [para] [package ncgi] provides routines to manipulate [ uri https://tools.ietf.org/html/rfc3875 CGI ] request arguments provided in the query string and form data, to set and get cookies, and to encode and decode www-url-encoded values. [para] [cmd ::ncgi] is a routine whose subroutines are the same as those documented below for the [const ::ncgi] namespace. When calling these routines as subroutines, omit [arg session] as it is passed automatically. To create a new CGI session, call [cmd {::ncgi .new}], and then use command it creates returns to work with request arguments. Use [cmd {::ncgi get}] to retrieve argument values, or use [cmd {::ncgi all}] for arguments that might occur multiple times. If only one CGI session is needed in the interpreter, [const ::ncgi] may be used directly. [para] [section Definitions] [list_begin definitions] [def multidict] A dictionary where the keys may not be unique [def {argument multidict}] A multidict where keys are names of request arguments provided in the query string and form data, and each value is itself a list containing the value for the argument and the corresponding dictionary of parameters. [list_end] [section Procedures] [list_begin definitions] [call [cmd ::ncgi] [method .new] [arg name] [opt "[arg option] [arg value]"]] Creates a routine named [arg name] that represents a new CGI session, and returns the name the new routine. The available options, primarily for use in the test suite, are [list_begin options] [opt_def body [arg body]] Use [arg body] as the body for the purpose of processing form data. [opt_def contenttype [arg contenttype]] Use [arg contenttype] as the contenttype for the purpose of processing form data. [opt_def form [arg formdata]] Use [arg formdata] as the form data. [opt_def querystring [arg querystring]] Use [arg querystring] as the query string. [list_end] [call [arg session] [method all] [arg name] [opt [arg default]]] Like [cmd ::ncgi::get], but returns a list of values matching [arg name] in the argument multidict. [call [arg session] [method body]] Returns the raw request body. [call [arg session] [method {cookies all}]] Returns a multidict of all cookie names and values. [call [arg session] [method {cookies get}] [opt [arg name]] [opt [arg default]]] Returns the value of the last cookiet named [arg name], or [arg default] it is provided and no such cookie exists. [call [arg session] [method decode] [arg str]] Decodes the www-url-encoded [arg str]. In this encoding special characters are represented with a %xx sequence, where xx is the character code in hex. [call [arg session] [method encode] [arg string]] Encodes [arg string] into www-url-encoded format. [call [arg session] [method exists] [arg name]] Returns [const true] if an CGI argument matching [arg name] is present and is [const false] otherwise. [call [arg session] [method form] [cmd get] [opt [arg name]]] Like [cmd ::ncgi::get], but only considers form arguments, not arguments in the query string. [call [arg session] [method get] [opt [arg name]] [opt [arg default]]] Returns a list containing the values matching [arg name] in the argument multidict. If [arg name] is not provided, returns the entire argument multidict. [call [arg session] [method {header send}] [opt [arg type]]] Serialize the response header to the session output. Produces a [ const Content-Type ] header and additional headers based on [arg args], which is a multidict of names and values. [arg type] defaults to [const text/html]. [call [arg session] [cmd importFile] [arg cmd] [arg name] [ opt [arg filename]]] Provides information about an uploaded file from a form field. Possible values for [arg cmd] are [list_begin definitions] [def "[option -client] [arg name]"] Returns the filename as sent by the client. [def "[option -type] [arg name]"] Returns the mime type of the uploaded file. [def "[option -data] [arg name]"] Returns the contents of the file. [def "[option -server] [arg name]"] Returns the name of a channel routine for the contents of the field named [arg name]. [list_end] [call [arg session] [method {query get}]] Returns the query data as a multidict. [call [arg session] [method {query set}] [arg {name value}]] Sets a query value. [call [arg session] [method {query string}]] Returns the raw query data. [call [arg session] [method redirect] [arg url]] Generates a response that causes a 302 redirect by the Web server. The [arg url] is the new URL that is the target of the redirect. The URL will be qualified with the current server and current directory, if necessary, to convert it into a full URL. [call [arg session] [method type]] Returns the Content-Type of the current CGI values. [call [cmd ::ncgi::urlStub] [opt [arg url]]] Returns the current URL, but without the protocol, server, and port. If [arg url] is specified, then it defines the URL for the current session. That value will be returned by future calls to [cmd ::ncgi::urlStub] [list_end] [section Examples] Uploading a file [example { HTML: <html> <form action="/cgi-bin/upload.cgi" method="POST" enctype="multipart/form-data"> Path: <input type="file" name="filedata"><br> |
︙ | ︙ |
Changes to modules/ncgi/ncgi.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # ncgi.tcl # # Basic support for CGI programs # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2012 Richard Hipp, Andreas Kupries # Copyright (c) 2013-2014 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Please note that Don Libes' has a "cgi.tcl" that implements version 1.0 # of the cgi package. That implementation provides a bunch of cgi_ procedures # (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for | > | | < < < | > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < | < < < < > > | < < < < < | | < < | < < < < > | | < | < < | < < | > > | > > > > > | | | < < | | > | > | < < | < < | < | | | | > > > | > > > > > > > > | | < < > | < < < < < < < < < | | | | < < > | | > | < < < | < | > > > > > > | | < < < < | < < < < < | < | | | | < > > > | | | | | < > < < < | < < > > > | > | > | > | | | > > | > | | > > | < < < < < < < < < | < < < | < < < < < | | | > > | | | < < < | | | < < < < | < < | > | | < | < < < < < < < < < < < | | < < < < < < < | < < < < < < < < < < < < | < < | | | | | | < | < < < < | < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | > > > > > > > > > > | < > | < < < | < < < < < < < < < | | < < | > > > > > > | | < < < < | | < < < < < < < < < < | < < | < | > | < < < | < < | | < < < | < < > | < < > | < < < > > | | > > > > | < | | | | | | | < | < > | > | | > > > > > > | < | > | < | | | < > | | | > > > > > > > > > > | > > > > | < < < | > | | < | | > | < < < > | > | > > > > > > > > > > > > > > > | < < | > | > > > | > > | > | < < | < > | < < | < < < | < | > > > > > > | > > | > > > | > > | > | | > > > | > | | > > > | > > | | < | | > | | < < | > > | > > > > > > > > > > > < | < < < | > > | | > | | > | < | | | > | > > > | | | > | < > > > | < | < < | > > | | < > > > > > > > | | | > | > | | > | > | | | > | < | < < < > > > > | | > > > > | | > > | > > > > | > > > | | | | | < > > > | < | < > > > | | > | > > > > > > > > > > > > > | < > > > > > > > > | < | | < < | | | < > > > | > | | | < < < > < | < < | | < | > > > > > > > < > | > | < < > > < | | > > > | > | | > > | | | > | > > | < | | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 | # ncgi.tcl # # Basic support for CGI programs # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2012 Richard Hipp, Andreas Kupries # Copyright (c) 2013-2014 Andreas Kupries # Copyright (c) 2018 Poor Yorick # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Please note that Don Libes' has a "cgi.tcl" that implements version 1.0 # of the cgi package. That implementation provides a bunch of cgi_ procedures # (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for # generating HTML. In contrast, the package provided here is primarly # concerned with processing input to CGI programs. # Note, I use the term "query data" to refer to the data that is passed in # to a CGI program. Typically this comes from a Form in an HTML browser. # The query data is composed of names and values, and the names can be # repeated. The names and values are encoded, and this module takes care # of decoding them. # We use newer string routines package require Tcl 8.6 package require {chan base} package require fileutil ; # Required by importFile. package require mime package require uri package provide ncgi 1.5.0 namespace eval ::ncgi { # Support for x-www-urlencoded character mapping # The spec says: "non-alphanumeric characters are replaced by '%HH'" variable i variable c variable map for {set i 1} {$i <= 256} {incr i} { set c [format %c $i] if {![string match \[a-zA-Z0-9\] $c]} { set map($c) %[format %.2X $i] } } # These are handled specially array set map { { } + \n %0D%0A } } proc ::ncgi::.namespace _ { namespace ensemble configure $_ -namespace } # ::ncgi::all # # Returns all the values of a named query element as a list, or # the empty list if $name was not not specified. Always returns # lists. Consider using ncgi::get instead. # # Arguments: # key The name of the query element # # Results: # The first value of the named element, or "" proc ::ncgi::all {_ name} { namespace upvar $_ query query form form $_ query get if {[form $_ exists]} { $_ form get } set result {} foreach {qname val} $query { if {$qname eq $name} { lappend result $val } } if {[form $_ exists]} { foreach {fname val} $form { if {$fname eq $name} { lappend result [lindex $val 0] } } } return $result } proc ::ncgi::body _ { global env namespace upvar $_ {*}{ body body content_length content_length method method } if {![info exists body]} { if {([info exists method] && $method eq {post}) && [info exist content_length] } { chan configure stdin -translation binary set body [read stdin $env(CONTENT_LENGTH)] } else { set body {} } } chan configure stdout -translation binary return $body } # ::ncgi::cookies # # Returns a multidict of incoming cookies. namespace eval ::ncgi::cookies { namespace ensemble create -parameters _ namespace export all get proc all {_ name} { namespace upvar $_ cookies cookies init $_ lmap {name1 val} $cookies { if {$name1 ne $name} continue lindex $val } } proc init _ { global env namespace upvar $_ cookies cookies if {![info exists cookies]} { if {[info exists env(HTTP_COOKIE)]} { set cookies [join [lmap pair [split $env(HTTP_COOKIE) \;] { split [string trim $pair] = }]] } else { set cookies {} } } return } proc get {_ args} { init $_ namespace upvar $_ cookies cookies switch [llength $args] { 2 { lassign $args key default if {[dict exists $cookies $key]} { return [dict get $cookies $key] } else { return $default } } 1 { return [dict get $cookies [lindex $args 0]] } 0 { return $cookies } default { error [list {wrong # args}] } } } } proc ::ncgi::delete _ { namespace delete [namespace ensemble configure $_ -namespace] } # ::ncgi::decode # # Decodes data in www-url-encoded format. # # Arguments: # An encoded value. # # Results: # The decoded value. proc ::ncgi::DecodeHex {hex} { return [binary decode hex $hex] } proc ::ncgi::decode str { # rewrite "+" back to space # protect \ from quoting another '\' set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str] # prepare to process all %-escapes regsub -all -nocase -- {%([E][A-F0-9])%([89AB][A-F0-9])%([89AB][A-F0-9])} \ $str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str regsub -all -nocase -- {%([CDcd][A-F0-9])%([89AB][A-F0-9])} \ $str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str regsub -all -nocase -- {%([A-F0-9][A-F0-9])} $str {\\u00\1} str # process \u unicode mapped chars return [subst -novar $str] } # ::ncgi::encode # # Encodes data in www-url-encoded format. # # Arguments: # A string # # Results: # The encoded value proc ::ncgi::encode string { variable map # 1 leave alphanumerics characters alone # 2 Convert every other character to an array lookup # 3 Escape constructs that are "special" to the tcl parser # 4 "subst" the result, doing all the array substitutions regsub -all -- \[^a-zA-Z0-9\] $string {$map(&)} string # This quotes cases like $map([) or $map($) => $map(\[) ... regsub -all -- {[][{})\\]\)} $string {\\&} string return [subst -nocommand $string] } proc ::ncgi::form_get {_ args} { namespace upvar $_ form form set type [$_ type] if {![info exists form]} { set form {} switch -glob $type { {} - text/xml* - application/x-www-form-urlencoded* - application/x-www-urlencoded* { foreach {key val} [urlquery [$_ body]] { lappend form $key [list $val {}] } } multipart/* { $_ multipart } default { return -code error "Unknown Content-Type: $type" } } } if {[llength $args] == 1} { lindex [dict get $form {*}$args] 0 } elseif {[llength $args] == 2} { set args [lassign $args[set args {}] key] lassign [dict get $form $key] value params dict get $params {*}$args } elseif {[llength $args]} { error [list wrong # args] } else { return $form } } proc ::ncgi::form_exists _ { namespace upvar $_ content_length content_length if {[info exists content_length]} { switch -glob [type $_] { {} - text/xml* - application/x-www-form-urlencoded* - application/x-www-urlencoded* - multipart/* { return 1 } } } return 0 } proc ::ncgi::headerfilter headers { join [lmap {key val} $headers[set headers {}] { if {[string tolower $key] in {content-type}} continue list $key $val }] } proc ::ncgi::header_send {_ type args} { namespace upvar $_ respons response set mimeout [mime::.new {} -canonical $type -params $args \ -addcontentid 0 -addmimeversion 0 -addmessageid 0 -string {} ] foreach {n v} [headerfilter [$_ response header get]] { $mimeout header set $n {*}$v } $_ response .destroy $mimeout serialize -chan ${_}::stdout ${_}::stdout flush $mimeout .destroy } # ::ncgi::get # # Returns the value of a named query element, or the empty string if # it was not not specified. This only returns the first value of # associated with the name. If you want them all (like all values # of a checkbox), use ncgi::all # # Arguments: # key The name of the query element # default The value to return if the value is not present # # Results: # The first value of the named element, or the default proc ::ncgi::get {_ args} { namespace upvar $_ form form query query $_ query get if {[form $_ exists]} { $_ form get } set merged [merge $_] if {![llength $args]} { return $merged } elseif {[llength $args] <= 2} { lassign $args key default try { return [lindex [dict get $merged $key] 0] } on error {} { return $default } } else { error [list {wrong # args}] } } # ::ncgi::importFile -- # # get information about a file upload field # # Arguments: # cmd one of '-server' '-client' '-type' '-data' # var cgi variable name for the file field # Results: # -server returns the name of the file on the server: side effect # is that the file gets stored on the server and the # script is responsible for deleting/moving the file # -client returns the name of the file sent from the client # -type returns the mime type of the file # -data returns a channel command for the contents of the file proc ::ncgi::importFile {_ cmd var {filename {}}} { namespace upvar $_ mimeparts mimeparts if {[$_ form exists]} { set form [$_ form get] } lassign [dict get $mimeparts $var] mime lassign [$mime header get content-disposition] cdisp dispparams switch -exact -- $cmd { -server { return [$mime body decode] } -client { if {[dict exists $dispparams filename]} { return [dict get $dispparams filename] } return {} } -type { lassign [$mime header get content-type] ctype params return $ctype } -data { return [$mime body decoded] } default { error "Unknown subcommand to ncgi::import_file: $cmd" } } } proc ::ncgi::merge _ { namespace upvar $_ form form query query $_ query get set query2 [join [lmap {key val} $query { list $key [list $val {}] }]] if {[$_ form exists]} { # form overrides query in a multidict list {*}$query2 {*}[join [lmap {key val} $form { list $key $val }]] } else { return $query2 } } # ::ncgi::multipart # # Parses $data into a multidict using the boundary provided in $type, # which is a complete Content-type value. Each value in the resulting # multi dict is a list where the first item is the value and the the # second item is a multidict where each key is the name of a header and # each value is a list containing the header value and a dictionary of # parameters for that header. proc ::ncgi::multipart _ { namespace upvar $_ form form mime mime mimeparts mimeparts set type [$_ type] set data [$_ body] set mime [mime::.new {} -string "Content-Type: $type\n\n$data"] set parts [$mime property parts] trace add variable mime unset [list apply [list {mime args} { if {[namespace which $mime] ne {}} { $mime .destroy } } $mime]] set results [list] foreach part $parts { set value [[$part body decoded] read] lassign [$part header get content-disposition] hvalue params if {$hvalue eq {form-data} && [dict exists $params name]} { set name [dict get $params name] dict unset params name } else { set name {} } lappend mimeparts $name $part lappend form $name [list $value $params] } return $form } # ::ncgi::.new # Creates a command representing a new cgi session and return the name of # that command. # arguments # name # The name of the command to create, or the empty string if a command # name should be automatically generated. # effects # Resets the cached query data and wipes any environment variables # associated with CGI inputs (like QUERY_STRING). proc ::ncgi::.new {_ name args} { if {$name eq {}} { set name [namespace current]::[info cmdcount] } elseif {![string match ::* $name]} { set name [uplevel 1 {namespace current}]::$name } set ns [namespace eval $name { namespace ensemble create namespace current }] # normalize $name set name [namespace which $name] ::tcllib::chan::base .new ${ns}::stdout stdout -close 0 namespace ensemble create -command ${ns}::header -map [list \ send [list header_send $name] ] mime::.new ${ns}::response -canonical text/html -spec cgi -string {} set map [dict merge [list decode decode encode encode {*}[join [lmap cmdname { .namespace .new all body cookies delete form get importFile input merge method multipart query redirect type urlStub } { list $cmdname [list $cmdname $name] }]]] [list \ header [list ${ns}::header] \ response [list ${ns}::response] \ stdout [list ${ns}::stdout] ]] namespace ensemble configure $name -map $map trace add command $name delete [list apply [list {old new op} { $old .destroy }]] # $query holds the raw query (i.e., form) data # This is treated as a cache, too, so you can call ncgi::query more than # once # $contenttype is the content-type, which affects how the query is parsed # $urlStub holds the URL corresponding to the current request # This does not include the server name. namespace upvar $ns \ _tmpfiles _tmpfiles \ body body \ content_length content_length \ contenttype contenttype \ env env \ form form \ listRestrict listRestrict \ method method \ query query \ querystring querystring \ urlStub urlStub \ # Map of transient files array set _tmpfiles {} # $listRestrict flags compatibility with Don Libes cgi.tcl when dealing # with form values that appear more than once. This bit gets flipped when # you use the ncgi::input procedure to parse inputs. set listRestrict 0 dict for {opt val} $args { switch $opt { body { set $opt $val set content_length [string length $body] } contenttype - env - form - querystring { set $opt $val } default { error [list {unknown reset option} $opt] } } } if {![info exists env]} { array set env [array get ::env] } if {[info exists env(CONTENT_LENGTH)] && [ string length $env(CONTENT_LENGTH)] != 0} { set content_length [expr {$env(CONTENT_LENGTH)}] } if {[info exists env(REQUEST_METHOD)]} { set method [string tolower $env(REQUEST_METHOD)] } return $name } # ::ncgi::parseMimeValue # # Parse a MIME header value, which has the form # value; param=value; param2="value2"; param3='value3' # # Arguments: # value The mime header value. This does not include the mime # header field name, but everything after it. # # Results: # A two-element list, the first is the primary value, # the second is in turn a name-value list corresponding to the # parameters. Given the above example, the return value is # { # value # {param value param2 value2 param3 value3} # } proc ::ncgi::parseMimeValue value { set parts [split $value \;] set results [list [string trim [lindex $parts 0]]] set paramList [list] foreach sub [lrange $parts 1 end] { if {[regexp -- {([^=]+)=(.+)} $sub match key val]} { set key [string trim [string tolower $key]] set val [string trim $val] # Allow single as well as double quotes if {[regexp -- {^(['"])(.*)\1} $val x quote val2]} { ; # need a " for balance # Trim quotes and any extra crap after close quote # remove quoted quotation marks set val [string map {\\" "\"" \\' "\'"} $val2] } lappend paramList $key $val } } if {[llength $paramList]} { lappend results $paramList } return $results } # ::ncgi::query_get # # Returns the query part of the URI # proc ::ncgi::query_get _ { namespace upvar $_ query query if {![info exists query]} { set query [urlquery [$_ query string]] } return $query } # ::ncgi::query_set # # set the value of $key in the query dictionary to $value # proc ::ncgi::query_set {_ key value} { namespace upvar $_ query query $_ query get set idx [lindex [lmap idx [lsearch -exact -all $key $query] { if {[$idx % 2]} continue set idx }] end] if {$idx >= 0} { set query [lreplace $query[set query {}] $idx $idx $value] } else { lappend query $key $value } return $value } # ::ncgi::query_string # # Reads the query data from the QUERY_STRING environment variable if # needed. # # Arguments: # none # # Results: # The raw query data. proc ::ncgi::query_string _ { namespace upvar $_ env env querystring querystring if {[info exists querystring]} { # This ensures you can call ncgi::query more than once, # and that you can use it with ncgi::reset return $querystring } set querystring {} if {[info exists env(QUERY_STRING)]} { set querystring $env(QUERY_STRING) } return $querystring } # ::ncgi::redirect # # Generate a redirect by returning a header that has a Location: field. # If the URL is not absolute, this automatically qualifies it to # the current server # # Arguments: # url The url to which to redirect # # Side Effects: # Outputs a redirect header proc ::ncgi::redirect {_ url} { namespace upvar $_ env env if {![regexp -- {^[^:]+://} $url]} { # The url is relative (no protocol/server spec in it), so # here we create a canonical URL. # request_uri The current URL used when dealing with relative URLs. # proto http or https |
︙ | ︙ | |||
766 767 768 769 770 771 772 | if {[string match /* $url]} { set url $proto://$server$port$url } else { regexp -- {^(.*/)[^/]*$} $request_uri match dirname set url $proto://$server$port$dirname$url } } | | > > | < | < | < < < < < < < < < < < < | < < < < < < < < | | | < < < < < < < < | < < < < < < < < | < < < > | < < < | < < < < < < < < < < < < | < < < < | | > > < | < < < < < < < < < < < < < < < < < < | | < | < < < < < < < | < < < < < < < | < < < | < < < | < < < | | < | | < > | < < < < < < < < < < < | < < < < < < < < < | < | < < < < | < < < < < < | | | < < < < < < < | < < > | | | | | < < | < | < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < | < < < < < > | < | | < < < | < < < < < < < < < < < < < | < | < < | > | > | | > | < | < < | | < < < < < < < < < < | | < < < < < < < | < < > | | < > > < < | | < < | | | > | > | < > > > | | < > > > > < < < < | | > > > | | | | > > | > > > | < > | < | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 | if {[string match /* $url]} { set url $proto://$server$port$url } else { regexp -- {^(.*/)[^/]*$} $request_uri match dirname set url $proto://$server$port$dirname$url } } set mimeout [mime::.new {} -canonical text/html -addcontentid 0 \ -addmimeversion 0 -addmessageid 0 \ -string "Please go to <a href=\"$url\">$url</a>\n" ] foreach {n v} [headerfilter [$_ response header get]] { $mimeout header set $n {*}$v } $_ response .destroy $mimeout header set Location $url $mimeout serialize -chan ${_}::stdout ${_}::stdout flush $mimeout .destroy return } # ::ncgi::type # # This returns the content type of the query data. # # Arguments: # none # # Results: # The content type of the query data. proc ::ncgi::type _ { namespace upvar $_ contenttype contenttype env env if {![info exists contenttype]} { if {[info exists env(CONTENT_TYPE)]} { set contenttype $env(CONTENT_TYPE) } else { return {} } } return $contenttype } # ::ncgi::urlquery # # Parses $data as a url-encoded query and returns a multidict containing # the query. # proc ::ncgi::urlquery data { set result {} # Any whitespace at the beginning or end of urlquery data is not # considered to be part of that data, so we trim it off. One special # case in which post data is preceded by a \n occurs when posting # with HTTPS in Netscape. foreach x [split [string trim $data] &] { # Turns out you might not get an = sign, # especially with <isindex> forms. set pos [string first = $x] set len [string length $x] if {$pos>=0} { if {$pos == 0} { # if the = is at the beginning ... if {$len>1} { # ... and there is something to the right ... set varname [string range $x 1 end] set val {} } else { # ... otherwise, all we have is an = set varname {} set val {} } } elseif {$pos==[expr {$len-1}]} { # if the = is at the end ... set varname [string range $x 0 [expr {$pos-1}]] set val "" } else { set varname [string range $x 0 [expr {$pos-1}]] set val [string range $x [expr {$pos+1}] end] } } else { # no = was found ... set varname $x set val {} } lappend result [decode $varname] [decode $val] } return $result } # ::ncgi::urlStub # # Set or return the URL associated with the current page. # This is for use by TclHttpd to override the default value # that otherwise comes from the CGI environment # # Arguments: # url (option) The url of the page, not counting the server name. # If not specified, the current urlStub is returned # # Side Effects: # May affects future calls to ncgi::urlStub # proc ::ncgi::urlStub {_ {url {}}} { global env namespace upvar $_ urlStub urlStub if {[string length $url]} { set urlStub $url return {} } elseif {[info exists urlStub]} { return $urlStub } else { if {[info exists env(SCRIPT_NAME)]} { set urlStub $env(SCRIPT_NAME) } else { set urlStub {} } return $urlStub } } namespace eval ::ncgi { namespace ensemble create -command [namespace current]::form \ -parameters _ -map { exists form_exists get form_get } namespace ensemble create -command [namespace current]::query \ -parameters _ -map { get query_get set query_set string query_string } .new dummy [namespace current] } |
Changes to modules/ncgi/ncgi.test.
1 2 3 4 5 6 7 8 9 10 11 | # -*- tcl -*- # Tests for the cgi module. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions # ------------------------------------------------------------------------- | > > > | | | | | > > | | | | | | > > > > > > > > > > | > | > | < > > > > | > > | > > | | > > > > > | | > | | | > > > | < | | | | | < > > > | > | | > > > > > > > > > > > > > > > > > > | | | | > > > | | | | < | | > > | | | < | | > | | | | | | | > | | | | | | | | | > | > | < | | > > | > | < | > | > | > | | | > | | | > | | | > | | | > | | | > | | | > | | | > | | | > | | | > | | > | | | | > | | | > | | | > | | | > | | | > | > | | | > > | | > | | > > | | | | | < | < > | | | | | < < < | | | | < | | | | | | < | | | > | | | | | > | | | | | < < | | | < < < | | | > > | | | | | > | | | | < < | > | | < | | | > | | > | | > > | > > > | > | | | | < | < < > | | | | < < | < < > | > | | | | | | | | | | | | | > | > | > | | < | | | | | | | > | | | | | | | | | | | | | | > | | > | | | | | | | | | | | > | | | | | | | | | | | | | | > | > | | | | | | | | | | | > | | | | | | | | | | | | | | > | > | | | | | | | | | | | > | | | | | | | | | | | | | | > | > | | | | | | | | | | | > | | | | | | | | | | | | | | | > | > | | | | | | | | | | | > | | | | | | | | | | | | | | | > | > | | > | | | | | | | | | | | | | | | | > > | | | > | | | | | | | | | > | | | | | | | > | > | | > | | | | | | | | | > | | | | | | | > | > > | | > | | | | | | | | | > | | | | | | | > | | | | | | | | | | | | | < < < | > | < | < | > | | > > | | > > > | < < | > | < < < | < < < > | | < | | < > > > > > | > | | < | > > | | | | | | | | | | | | | | | | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > | | | | | | | | | | | > | | > > | > | > > > > > > > | | > > > > > > > > | | > > > > | > | | > > > > > > > | | > > > > > > > > > > | | > > > > > | > > > > > | | > > > > > > > > > > > > > > | > | | > | > | > > > > > | | > > > > > | | > > > > > > | | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 | # -*- tcl -*- # Tests for the cgi module. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions # Copyright (c) 2018 Poor Yorick # # RCS: @(#) $Id: ncgi.test,v 1.28 2012/05/03 17:56:07 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 testing { useLocal ncgi.tcl ncgi } proc main {} {try { global env global auto_path set sub_ap $auto_path lappend sub_ap $::tcltest::testsDirectory set ncgiFile [localPath ncgi.tcl] set futlFile [tcllibPath fileutil/fileutil.tcl] set cmdlFile [tcllibPath cmdline/cmdline.tcl] proc makescript script { string map [list @script@ [list $script]] { after 0 [list coroutine main try @script@ \ on error {tres topts} { exit 1 } finally { set done 1 }] vwait done exit } } proc resetenv {} { global env foreach varname { CONTENT_LENGTH CONTENT_TYPE HTTP_COOKIE HTTPS QUERY_STRING REQUEST_METHOD REQUEST_URI SERVER_NAME SERVER_PORT } { if {[info exists env($varname)]} { unset env($varname) } } } proc withncgi args { set script [lindex $args end] set args [lreplace $args end end] ncgi .new ncgi1 {*}$args catch [list uplevel 1 $script] cres copts ncgi1 delete resetenv return -options $copts $cres } test ncgi-1.1 {[ncgi .new]} { withncgi { list [info exist [ncgi1 .namespace]::query] [ info exist [ncgi1 .namespace]::contenttype] } } {0 0} test ncgi-1.2 {[ncgi reset]} { withncgi querystring query=reset { list [set [ncgi1 .namespace]::querystring] [info exists [ ncgi1 .namespace]::contenttype] } } {query=reset 0} test ncgi-1.3 {[ncgi reset]} { withncgi querystring query=reset contenttype text/plain { list [set [ncgi1 .namespace]::querystring] [ set [ncgi1 .namespace]::contenttype] } } {query=reset text/plain} test ncgi-2.1 {[ncgi query] fake query data} { withncgi querystring fake=query { ncgi1 query get list [set [ncgi1 .namespace]::querystring] [ set [ncgi1 .namespace]::query] } } {fake=query {fake query}} test ncgi-2.2 {[ncgi query] GET} { set env(REQUEST_METHOD) GET set env(QUERY_STRING) name=value withncgi { ncgi1 query get list [set [ncgi1 .namespace]::querystring] [ set [ncgi1 .namespace]::query] } } {name=value {name value}} test ncgi-2.3 {[ncgi query] HEAD} { set env(REQUEST_METHOD) HEAD withncgi { ncgi1 query get set [ncgi1 .namespace]::query } } {} test ncgi-2.4 {[ncgi query] POST} { set env(REQUEST_METHOD) POST set env(CONTENT_LENGTH) 10 withncgi { makeFile [format { set auto_path {%s} source {%s} source {%s} source {%s} ncgi .new ncgi1 ncgi1 body puts [set [ncgi1 .namespace]::body] ncgi1 delete } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 ; # {} set f [open |[list $::tcltest::tcltest test1] r+] puts $f name=value flush $f gets $f line close $f removeFile test1 set line } } name=value test ncgi-2.5 {ncgi::test} { set env(CONTENT_TYPE) text/html withncgi { ncgi1 type } } text/html test ncgi-2.6 {ncgi::test} { set env(CONTENT_TYPE) text/html withncgi querystring foo=bar contenttype text/plain { ncgi1 type } } text/plain test ncgi-3.1 {ncgi::decode} { ncgi decode abcdef0123 } abcdef0123 test ncgi-3.2 {ncgi::decode} { ncgi decode {[abc]def$0123\x} } {[abc]def$0123\x} test ncgi-3.3 {ncgi::decode} { ncgi decode {[a%25c]def$01%7E3\x%3D} } {[a%c]def$01~3\x=} test ncgi-3.4 {ncgi::decode} { ncgi decode {hello+world} } {hello world} test ncgi-3.5 {ncgi::decode} { ncgi decode {aik%C5%ABloa} } "aik\u016Bloa" ; # u+macron test ncgi-3.6 {ncgi::decode} { ncgi decode {paran%C3%A1} } "paran\u00E1" ; # a+acute test ncgi-3.7 {ncgi::decode, bug 3601995} { ncgi decode {%C4%85} } "\u0105" ; # a+ogonek test ncgi-3.8 {ncgi::decode, bug 3601995} { ncgi decode {%E2%80%A0} } "\u2020" ; # dagger test ncgi-3.9 {ncgi::decode, bug 3601995} { ncgi decode {%E2%A0%90} } "\u2810" ; # a braille pattern test ncgi-3.10 {ncgi::decode, bug 3601995} { ncgi decode {%E2%B1} } "%E2%B1" ; # missing byte trailing %A0, do not accept/decode, pass through. test ncgi-4.1 {ncgi::encode} { ncgi encode abcdef0123 } abcdef0123 test ncgi-4.2 {ncgi::encode} { ncgi encode "\[abc\]def\$0123\\x" } {%5Babc%5Ddef%240123%5Cx} test ncgi-4.3 {ncgi::encode} { ncgi encode {hello world} } {hello+world} test ncgi-4.4 {ncgi::encode} { ncgi encode "hello\nworld\r\tbar" } {hello%0D%0Aworld%0D%09bar} test ncgi-5.1 {ncgi::query get} { withncgi querystring name=hello+world&name2=%7ewelch { ncgi1 query get } } {name {hello world} name2 ~welch} test ncgi-5.2 {ncgi::merge} { withncgi querystring name=&name2 contenttype application/x-www-urlencoded { ncgi1 merge } } {name {{} {}} name2 {{} {}}} test ncgi-5.3 {ncgi::merge} { withncgi querystring name=&name2 \ contenttype application/x-www-form-urlencoded { ncgi1 merge } } {name {{} {}} name2 {{} {}}} test ncgi-5.4.1 {ncgi::merge} { withncgi querystring name=&name2 contenttype application/xyzzy { set code [catch {ncgi1 merge} err] list $code $err } } {0 {name {{} {}} name2 {{} {}}}} test ncgi-5.4.2 {ncgi::merge} { withncgi body name=&name2 contenttype application/xyzzy { set code [catch {ncgi1 merge} err] list $code $err } } {0 {}} test ncgi-5.4.3 {ncgi::merge} { withncgi body name=&name2 contenttype application/xyzzy { set code [catch {ncgi1 form get} err] list $code $err } } {1 {Unknown Content-Type: application/xyzzy}} # multipart tests at the end because I'm too lazy to renumber the tests test ncgi-6.1 {query get, anonymous values, redundant keys} { withncgi querystring name=&name2 { ncgi1 query get } } {name {} name2 {}} test ncgi-7.1 {ncgi::get} { withncgi querystring name=value&name2=value2 { ncgi1 get } } {name {value {}} name2 {value2 {}}} test ncgi-7.2 {ncgi::get} { withncgi querystring nameList=value1+stuff&nameList=value2+more { ncgi1 all nameList } } {{value1 stuff} {value2 more}} test ncgi-7.3 {ncgi::get} { withncgi querystring name=value&name=value2 { catch {ncgi1 get} err set err } } {name {value {}} name {value2 {}}} test ncgi-8.1.1 {ncgi::value} { withncgi querystring nameList=val+ue&nameList=value2 { ncgi1 get nameList } } value2 test ncgi-8.1.2 {ncgi::value} { withncgi querystring nameList=val+ue&nameList=value2 { ncgi1 all nameList } } {{val ue} value2} test ncgi-8.2.1 {ncgi::value} { withncgi querystring name=val+ue&name=value2 { ncgi1 get name } } value2 test ncgi-8.2.2 {ncgi::value} { withncgi querystring name=val+ue&name=value2 { ncgi1 all name } } {{val ue} value2} test ncgi-8.3 {ncgi::get default} { withncgi querystring name=val+ue&name=value2 { ncgi get noname } } {} test ncgi-9.1 {ncgi::valueList} { withncgi querystring name=val+ue&name=value2 { ncgi1 all name } } {{val ue} value2} test ncgi-9.2 {ncgi::valueList} { withncgi querystring name=val+ue&name=value2 { ncgi1 all noname } } {} set URL http://www.tcltk.com/index.html test ncgi-11.1 {ncgi::redirect} { set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 redirect %s ncgi1 delete } err eopts]} { puts stderr [dict get $eopts -errorinfo] puts $err } } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL\n\nPlease go to <a href=\"$URL\">$URL</a>\n" set URL /elsewhere/foo.html set URL2 http://www/elsewhere/foo.html test ncgi-11.2 {ncgi::redirect} { set env(REQUEST_URI) http://www/cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s set ncgi [ncgi .new {}] $ncgi response cookie set CookieName 12345 $ncgi redirect %s $ncgi delete } err copts]} { puts [dict get $copts -errorinfo] } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nSet-Cookie: CookieName=12345\n\t; HttpOnly\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 http://www.scriptics.com/cgi-bin/foo.html test ncgi-11.3 {ncgi::redirect} { set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 redirect %s ncgi1 delete } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 http://www.scriptics.com/cgi-bin/foo.html test ncgi-11.4 {ncgi::redirect} { set env(REQUEST_URI) /cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 80 makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 redirect %s ncgi delete } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 http://www.scriptics.com:8000/cgi-bin/foo.html test ncgi-11.5 {ncgi::redirect} { set env(REQUEST_URI) /cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 8000 makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 redirect %s ncgi1 delete } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL foo.html set URL2 https://www.scriptics.com/cgi-bin/foo.html test ncgi-11.6 {ncgi::redirect} { set env(REQUEST_URI) /cgi-bin/test.cgi set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) www.scriptics.com set env(SERVER_PORT) 443 set env(HTTPS) on makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 redirect %s ncgi1 delete } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" set URL login.tcl set URL2 https://foo.com/cgi-bin/login.tcl test ncgi-11.7 {ncgi::redirect} { set env(REQUEST_URI) https://foo.com/cgi-bin/view.tcl?path=/a/b/c set env(REQUEST_METHOD) GET set env(QUERY_STRING) {} set env(SERVER_NAME) foo.com set env(SERVER_PORT) 443 set env(HTTPS) on makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 redirect %s ncgi1 delete } cres copts]} { puts stderr [dict get $copts -errorinfo] exit 1 } exit } $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n" test ncgi-12.1 {ncgi::header} { makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 header send text/html ncgi1 delete } err copts]} { puts stderr [dict get $copts -errorinfo] exit 1 } exit } $sub_ap $cmdlFile $futlFile $ncgiFile]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\n\n" test ncgi-12.2 {ncgi::header} { makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 header send text/plain ncgi1 delete } err copts]} { puts stderr [dict get $copts -errorinfo] exit 1 } exit } $sub_ap $cmdlFile $futlFile $ncgiFile]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/plain\n\n" test ncgi-12.3 {ncgi::header} { makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 response header set X-Comment {This is a test} ncgi1 header send text/html ncgi1 delete } cres copts]} { puts stderr [dict get $copts -errorinfo] exit 1 } exit } $sub_ap $cmdlFile $futlFile $ncgiFile]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nX-Comment: This is a test\n\n" test ncgi-12.4 {ncgi::header} { makeFile [makescript [format { set auto_path {%s} if {[catch { source %s source %s source %s ncgi .new ncgi1 ncgi1 response cookie set Name The+Value ncgi1 header send text/html } err]} { puts $err } exit } $sub_ap $cmdlFile $futlFile $ncgiFile]] test1 set f [open |[list $::tcltest::tcltest test1] r+] set res [read $f] close $f removeFile test1 set res } "Content-Type: text/html\nSet-Cookie: Name=The+Value\n\t; HttpOnly\n\n" test ncgi-14.2 {ncgi::multipart} { withncgi contenttype multipart/form-data body {} { catch {ncgi1 get} err } set err } {end-of-string encountered while parsing multipart/form-data} test ncgi-14.3 {ncgi::multipart} { set in [open [file join [file dirname [info script]] formdata.txt]] set X [read $in] close $in foreach line [split $X \n] { if {[string length $line] == 0} { break } if {[regexp {^Content-Type: (.*)$} $line x type]} { break } } regsub ".*?\n\n" $X {} X withncgi contenttype $type body $X { ncgi1 get } } [list \ field1 [list value {}] \ field2 [list {another value} {}] \ the_file_name [list { <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> } \ [list \ filename {C:Program FilesNetscapeCommunicatorProgramnareadme.htm} ]]] test ncgi-14.4 {ncgi::multipart} { set in [open [file join [file dirname [info script]] formdata.txt]] set X [read $in] close $in foreach line [split $X \n] { if {[string length $line] == 0} { break } if {[regexp {^Content-Type: (.*)$} $line x type]} { break } } regsub ".*?\n\n" $X {} X withncgi body $X contenttype $type { list [ncgi1 get field1] [ncgi1 get field2] [ ncgi1 get the_file_name] } } {value {another value} { <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> }} ## ------------ tests for binary content and file upload ---------------- ## some utility procedures to generate content variable binary_content " <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> " variable form_boundary {17661509020136} proc genformcontent_type {} { variable form_boundary return "multipart/form-data; boundary=\"$form_boundary\"" } proc genformdatapart {name cd value} { variable form_boundary return "--$form_boundary\nContent-Disposition: form-data; name=\"$name\"$cd\n\n$value\n" } proc genformdata {bcontent} { variable form_boundary set a [genformdatapart field1 "" {value}] set b [genformdatapart field2 "" {another value}] set c [genformdatapart the_file_name "; filename=\"C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm\"\nContent-Type: text/html" $bcontent] return "$a$b$c--$form_boundary--\n" } test ncgi-14.5 {ncgi::multipart--check binary file} { set X [genformdata $binary_content] withncgi body $X contenttype [genformcontent_type] { set content [ncgi1 get the_file_name] list [ncgi1 get field1] [ncgi1 get field2] $content } } [list value {another value} [string map [list \r {}] $binary_content]] test ncgi-14.6 {ncgi::multipart [query set]} { set in [open [file join [file dirname [info script]] formdata.txt]] set X [read $in] close $in foreach line [split $X \n] { if {[string length $line] == 0} { break } if {[regexp {^Content-Type: (.*)$} $line x type]} { break } } regsub ".*?\n\n" $X {} X withncgi body $X contenttype $type { ncgi1 query set userval1 foo ncgi1 query set userval2 {a b} list [ncgi1 get field1] [ncgi1 get field2] [ ncgi1 get userval1] [ncgi1 get userval2] [ ncgi1 get the_file_name] } } {value {another value} foo {a b} { <center><h1> Netscape Address Book Sync for Palm Pilot User Guide </h1></center> }} test ncgi-15.1.1 {ncgi query set} { withncgi querystring nameList=val+ue&nameList=value2 { ncgi1 query set foo 1 ncgi1 query set bar {a b} list [ncgi1 get nameList] [ncgi1 get foo] [ncgi1 get bar] } } {value2 1 {a b}} test ncgi-15.1.2 {ncgi query set} { withncgi querystring nameList=val+ue&nameList=value2 { ncgi1 query set foo 1 ncgi1 query set bar {a b} list [ncgi1 all nameList] [ncgi1 get foo] [ ncgi1 get bar] } } {{{val ue} value2} 1 {a b}} test ncgi-16.1 {ncgi::importFile} { set X [genformdata $binary_content] withncgi body $X contenttype [genformcontent_type] { ncgi1 importFile -client the_file_name } } {C:Program FilesNetscapeCommunicatorProgramnareadme.htm} test ncgi-16.2 {ncgi::importFile - content type} { global binary_content set X [genformdata $binary_content] withncgi body $X contenttype [genformcontent_type] { ncgi1 importFile -type the_file_name } } text/html test ncgi-16.3 {ncgi::importFile -- file contents} { global binary_content set X [genformdata $binary_content] withncgi contenttype [genformcontent_type] body $X { set chan [ncgi1 importFile -data the_file_name] set res [$chan read] $chan close return $res } } $binary_content test ncgi-16.4 {ncgi::importFile -- save file} { global binary_content set X [genformdata $binary_content] withncgi contenttype [genformcontent_type] body $X { set chan [ncgi1 importFile -server the_file_name] # get the contents of the local file to verify $chan configure -translation binary set content [$chan read] $chan close return $content } } $binary_content test ncgi-16.5 {ncgi::importFile -- save file, given name} { global binary_content set X [genformdata $binary_content] withncgi contenttype [genformcontent_type] body $X { set chan [ncgi1 importFile -server the_file_name] # get the contents of the local file to verify $chan configure -translation binary set content [$chan read] $chan close return $content } } $binary_content test ncgi-16.6 {ncgi::importFile -- bad input} { set X "bad multipart data" withncgi contenttype [genformcontent_type] body $X { catch {ncgi1 importFile -client the_file_name} res return $res } } {end-of-string encountered while parsing multipart/form-data} test ncgi-17.1 {ncgi::names} { withncgi querystring name=hello+world&name2=%7ewelch { dict keys [ncgi1 get] } } {name name2} test ncgi-17.2 {ncgi::names} { withncgi querystring name=&name2 \ contenttype application/x-www-urlencoded { dict keys [ncgi1 get] } } {name name2} test ncgi-17.3 {ncgi::names} { withncgi querystring name=&name2 \ contenttype application/x-www-form-urlencoded { dict keys [ncgi1 get] } } {name name2} test ncgi-17.4 {ncgi::names} { withncgi querystring name=&name2 contenttype application/xyzzy { set code [catch {ncgi1 get} err] list $code $err } } {0 {name {{} {}} name2 {{} {}}}} # ------------------------------------------------------------------------- test ncgi-18.0 {ncgi::cookie::get} { set env(HTTP_COOKIE) {one=1;two=2;two=3;three=4} withncgi { ncgi1 cookies get } } {one 1 two 2 two 3 three 4} test ncgi-18.1 {ncgi::cookie::get} { set env(HTTP_COOKIE) {one=1;two=2;two=3;three=4} withncgi { ncgi1 cookies get two } } 3 test ncgi-18.2 {ncgi::cookie::all} { set env(HTTP_COOKIE) {one=1;two=2;two=3;three=4} withncgi { ncgi1 cookies all two } } {2 3} # ------------------------------------------------------------------------- testsuiteCleanup return } finally { set [namespace current]::done 1 }} after 0 [list ::coroutine [info cmdcount]_main [namespace current]::main] vwait [namespace current]::done return |
Changes to modules/ncgi/pkgIndex.tcl.
|
| | | > | 1 2 3 | if {![package vsatisfies [package provide Tcl] 8.4]} return package ifneeded ncgi 1.4.3 [list source $dir/ncgi-1.4.tcl] package ifneeded ncgi 1.5.0 [list source $dir/ncgi.tcl] |
Changes to modules/nettool/build/build.tcl.
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | ### # topic: 65dfea29d424543cdfc0e1cbf9f90295ef6214cb # description: # This script digests the raw data from # http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.csv # And produces a summary ### proc ::record {service port type usage} { if { $port eq {} } return if {$service eq {} && $type in {tcp udp {}} && $usage != "Reserved"} { ladd ::available_port($port) {*}$type return } unset -nocomplain ::available_port($port) lappend ::busy_port($port) $type $usage #puts [list busy $service $port $type $usage] } for {set x 0} {$x < 65536} {incr x} { set ::available_port($x) {} } | > > > > > > > > > > | < | 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 | ### # topic: 65dfea29d424543cdfc0e1cbf9f90295ef6214cb # description: # This script digests the raw data from # http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.csv # And produces a summary ### proc ::ladd {varname args} { upvar 1 $varname list if {![info exist list]} { set list {} } foreach item $args { if {$item ni $list} { lappend list $item } } return $list } proc ::record {service port type usage} { if { $port eq {} } return if {$service eq {} && $type in {tcp udp {}} && $usage != "Reserved"} { ladd ::available_port($port) {*}$type return } unset -nocomplain ::available_port($port) lappend ::busy_port($port) $type $usage #puts [list busy $service $port $type $usage] } for {set x 0} {$x < 65536} {incr x} { set ::available_port($x) {} } source [file join $moddir .. csv csv.tcl] set fin [open [file join $srcdir service-names-port-numbers.csv] r] set headers [gets $fin] set thisline {} while {[gets $fin line]>=0} { append thisline \n$line if {![csv::iscomplete $line]} continue set lline [csv::split $line] |
︙ | ︙ |
Deleted modules/nettool/nettool.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/nns/common.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # common.test: Tests for the common code of the name service # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # common.test: Tests for the common code of the name service # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal common.tcl nameserv::common } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/ntp/time.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal time.tcl time } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/oodialect/oodialect.tcl.
1 2 3 4 5 6 7 8 9 | ### # oodialect.tcl # # Copyright (c) 2015-2018 Sean Woods # Copyright (c) 2015 Donald K Fellows # # BSD License ### # @@ Meta Begin | | < < < > > > > > > | | > | > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | ### # oodialect.tcl # # Copyright (c) 2015-2018 Sean Woods # Copyright (c) 2015 Donald K Fellows # # BSD License ### # @@ Meta Begin # Package oo::dialect 0.4 # Meta platform tcl # Meta summary A utility for defining a domain specific language for TclOO systems # Meta description This package allows developers to generate # Meta description domain specific languages to describe TclOO # Meta description classes and objects. # Meta category TclOO # Meta subject oodialect # Meta require {Tcl 8.6} # Meta author Sean Woods # Meta author Donald K. Fellows # Meta license BSD # @@ Meta End namespace eval ::oo::dialect { namespace export create # Allow test rigs to overwrite the flags before invoking this script foreach {flag test} { tip470 {package vsatisfies [package provide Tcl] 8.7} } { if {![info exists ::oo::dialect::has($flag)]} { set ::oo::dialect::has($flag) [eval $test] } } } proc ::oo::dialect::Push {class} { ::variable class_stack lappend class_stack $class } proc ::oo::dialect::Peek {} { ::variable class_stack return [lindex $class_stack end] } proc ::oo::dialect::Pop {} { ::variable class_stack set class_stack [lrange $class_stack 0 end-1] } if {$::oo::dialect::has(tip470)} { proc ::oo::dialect::current_class {} { return [uplevel 1 self] } } else { proc ::oo::dialect::current_class {} { tailcall Peek } } ### # This proc will generate a namespace, a "mother of all classes", and a # rudimentary set of policies for this dialect. ### proc ::oo::dialect::create {name {parent ""}} { variable has set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name] ::namespace eval $NSPACE {::namespace eval define {}} ### # Build the "define" namespace ### if {$parent eq ""} { ### # With no "parent" language, begin with all of the keywords in # oo::define ### foreach command [info commands ::oo::define::*] { set procname [namespace tail $command] interp alias {} ${NSPACE}::define::$procname {} \ ::oo::dialect::DefineThunk $procname } # Create an empty dynamic_methods proc proc ${NSPACE}::dynamic_methods {class} {} namespace eval $NSPACE { ::namespace export dynamic_methods ::namespace eval define {::namespace export *} } set ANCESTORS {} } else { ### # If we have a parent language, that language already has the # [oo::define] keywords as well as additional keywords and behaviors. # We should begin with that ### set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent] apply [list parent { ::namespace export dynamic_methods ::namespace import -force ${parent}::dynamic_methods } $NSPACE] $pnspace apply [list parent { ::namespace import -force ${parent}::define::* ::namespace export * } ${NSPACE}::define] $pnspace set ANCESTORS [list ${pnspace}::object] } ### # Build our dialect template functions ### proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] { ### # To facilitate library reloading, allow # a dialect to create a class from DEFINE ### set class [::oo::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass] if {[info commands $class] eq {}} { %NSPACE%::class create $class {*}${args} } else { ::oo::dialect::Define %NSPACE% $class {*}${args} } }] interp alias {} ${NSPACE}::define::current_class {} \ ::oo::dialect::current_class interp alias {} ${NSPACE}::define::aliases {} \ ::oo::dialect::Aliases $NSPACE interp alias {} ${NSPACE}::define::superclass {} \ ::oo::dialect::SuperClass $NSPACE if {[info command ${NSPACE}::class] ne {}} { ::rename ${NSPACE}::class {} |
︙ | ︙ | |||
129 130 131 132 133 134 135 | ### uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { %NSPACE%::class create %NSPACE%::object { superclass %ANCESTORS% # Put MOACish stuff in here } }] | < | | | | | < | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 | ### uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { %NSPACE%::class create %NSPACE%::object { superclass %ANCESTORS% # Put MOACish stuff in here } }] if { "${NSPACE}::class" ni $::oo::dialect::core_classes } { lappend ::oo::dialect::core_classes "${NSPACE}::class" } if { "${NSPACE}::object" ni $::oo::dialect::core_classes } { lappend ::oo::dialect::core_classes "${NSPACE}::object" } } # Support commands; not intended to be called directly. proc ::oo::dialect::NSNormalize {namespace qualname} { if {![string match ::* $qualname]} { set qualname ${namespace}::$qualname |
︙ | ︙ | |||
242 243 244 245 246 247 248 | tailcall ::oo::define $class superclass {*}[dict keys $unique] } ### # Implementation of the common portions of the the metaclass for our # languages. ### | | | > > > > > | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | tailcall ::oo::define $class superclass {*}[dict keys $unique] } ### # Implementation of the common portions of the the metaclass for our # languages. ### if {[info command ::oo::dialect::MotherOfAllMetaClasses] eq {}} { ::oo::class create ::oo::dialect::MotherOfAllMetaClasses { superclass ::oo::class constructor {define definitionScript} { $define [self] { superclass } $define [self] $definitionScript } method aliases {} { if {[info exists ::oo::dialect::aliases([self])]} { return $::oo::dialect::aliases([self]) } } } } namespace eval ::oo::dialect { variable core_classes {::oo::class ::oo::object} } package provide oo::dialect 0.4 |
Changes to modules/oodialect/pkgIndex.tcl.
|
| | | 1 | package ifneeded oo::dialect 0.4 [list source [file join $dir oodialect.tcl]] |
Changes to modules/oometa/oometa.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | } # ------------------------------------------------------------------------- # Test properties oo::class create foo { meta set const color: blue | | > | | | > > | | | | 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 | } # ------------------------------------------------------------------------- # Test properties oo::class create foo { meta set const color: blue constructor args { my _staticInit my configure {*}$args } } oo::class create bar { superclass ::foo meta set const shape: oval option color { label Color default green } } test oo-class-meta-001 {Test accessing properties} { foo meta get const color: } blue # Broken not fixing #test oo-class-meta-002 {Test accessing properties} { # bar meta get const color: #} blue test oo-class-meta-003 {Test accessing properties} { bar meta get const shape: } oval bar create cheers color pink # Pulling the meta data from const will return # the value specified in the class # Broken not fixing #test oo-object-meta-001 {Test accessing properties} { # cheers meta get const color: #} blue # Accessing the data via cget pulls from the local # definition test oo-object-meta-001a {Test accessing properties} { cheers meta cget color } green # pink - Meta CGET is no longer connected to the local object's config |
︙ | ︙ | |||
78 79 80 81 82 83 84 | } oval test oo-object-meta-003 {Test accessing properties} { cheers cget color } pink bar create moes | > | | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | } oval test oo-object-meta-003 {Test accessing properties} { cheers cget color } pink bar create moes # Broken not fixing #test oo-object-meta-004 {Test accessing properties} { # moes meta get const color: #} blue test oo-object-meta-004a {Test accessing properties} { moes cget color } green test oo-object-meta-004a {Test accessing properties} { moes cget color: |
︙ | ︙ | |||
113 114 115 116 117 118 119 | #oo::define ::foo property woozle whoop ::foo meta set const woozle: whoop test oo-modclass-meta-001 {Test accessing properties of an altered class} { foo meta get const woozle: } whoop | > | | | > | | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | #oo::define ::foo property woozle whoop ::foo meta set const woozle: whoop test oo-modclass-meta-001 {Test accessing properties of an altered class} { foo meta get const woozle: } whoop # Broken, not fixing #test oo-modclass-meta-002 {Test accessing properties of the descendent of an altered class} { # bar meta get const woozle: #} whoop # Broken not fixing #test oo-modobject-meta-001 {Test the accessing of properties of an instance of an altered class} { # moes meta get const woozle: #} whoop test obj-meta-for-001 {Test object meta for} { set output {} moes meta for {key value} option { lappend output $key $value } set output |
︙ | ︙ | |||
155 156 157 158 159 160 161 | # ------------------------------------------------------------------------- # Test of recursive dicts oo::class create baz { superclass ::bar | | > | | | | | 161 162 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 | # ------------------------------------------------------------------------- # Test of recursive dicts oo::class create baz { superclass ::bar meta set option color default: purple } test obj-meta-recursive-1 {Test that meta set works with recursive dicts} { set result {} baz meta get option color default: } {purple} # Broken, not fixing #test obj-meta-recursive-2 {Test that meta set works with recursive dicts} { # set result {} # baz meta get option color label: #} {Color} ### # New test, of mixins ### oo::class create mixin-test-A { meta set const color: blue |
︙ | ︙ |
Changes to modules/otp/otp.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal otp.tcl otp } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/png/png.test.
1 2 3 4 5 6 7 8 9 10 11 | # -*- tcl -*- # png.test: tests for png decoding and manipulation. # # Copyright (c) 2004 by Andreas Kupries <[email protected]> # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # -*- tcl -*- # png.test: tests for png decoding and manipulation. # # Copyright (c) 2004 by Andreas Kupries <[email protected]> # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 # Trf / tcllibc support { use crc/crc32.tcl crc32 ::crc } testing { |
︙ | ︙ |
Changes to modules/pop3/pop3.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 tcltest::testConstraint hastls [expr {![catch {package require tls}]}] support { #use snit/snit.tcl snit ;# comm futures, not used, still a dependency #use comm/comm.tcl comm |
︙ | ︙ |
Changes to modules/pop3d/pop3d.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # pop3d.tcl -- # # Implementation of a pop3 server for Tcl. # # Copyright (c) 2002-2009 by Andreas Kupries # Copyright (c) 2005 by Reinhard Max (-socket option) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require md5 ; # tcllib | APOP | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # pop3d.tcl -- # # Implementation of a pop3 server for Tcl. # # Copyright (c) 2002-2009 by Andreas Kupries # Copyright (c) 2005 by Reinhard Max (-socket option) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require md5 ; # tcllib | APOP package require -exact mime 1.6; # tcllib | storage callback package require log ; # tcllib | tracing package provide pop3d 1.1.0 namespace eval ::pop3d { # Data storage in the pop3d module # ------------------------------- |
︙ | ︙ | |||
88 89 90 91 92 93 94 | # "both". variable capabilities \ [list \ USER both \ PIPELINING both \ "IMPLEMENTATION $server" trans \ ] | | | | 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 | # "both". variable capabilities \ [list \ USER both \ PIPELINING both \ "IMPLEMENTATION $server" trans \ ] # -- UIDL -- not implemented -- # Only export one command, the one used to instantiate a new server namespace export new } # ::pop3d::new -- # # Create a new pop3 server with a given name; if no name is given, use # pop3dX, where X is a number. # # Arguments: # name name of the pop3 server; if null, generate one. # # Results: # name name of the pop3 server created proc ::pop3d::new {{name ""}} { variable counter if { [llength [info level 0]] == 1 } { incr counter set name "pop3d${counter}" } if { ![string equal [info commands ::$name] ""] } { return -code error "command \"$name\" already exists, unable to create pop3 server" |
︙ | ︙ | |||
156 157 158 159 160 161 162 | # Varies based on command to perform proc ::pop3d::Pop3dProc {name {cmd ""} args} { # Do minimal args checks here if { [llength [info level 0]] == 2 } { return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" } | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | # Varies based on command to perform proc ::pop3d::Pop3dProc {name {cmd ""} args} { # Do minimal args checks here if { [llength [info level 0]] == 2 } { return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" } # Split the args into command and args components if { [llength [info commands ::pop3d::_$cmd]] == 0 } { variable commands set optlist [join $commands ", "] set optlist [linsert $optlist "end-1" "or"] return -code error "bad option \"$cmd\": must be $optlist" } |
︙ | ︙ | |||
502 503 504 505 506 507 508 | } proc ::pop3d::HandleCommand {name sock} { # @c Called by the event system after arrival of a new command for # @c connection. # @a sock: Direct access to the channel representing the connection. | | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 | } proc ::pop3d::HandleCommand {name sock} { # @c Called by the event system after arrival of a new command for # @c connection. # @a sock: Direct access to the channel representing the connection. # Client closed connection, bye bye if {[eof $sock]} { CloseConnection $name $sock return } # line was incomplete, wait for more |
︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 | set cstate(msg) 0 if {!$noStorage} { set cstate(msg) [uplevel #0 [linsert $storCmd end \ stat $cstate(storage)]] set cstate(size) [uplevel #0 [linsert $storCmd end \ size $cstate(storage)]] } | | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 | set cstate(msg) 0 if {!$noStorage} { set cstate(msg) [uplevel #0 [linsert $storCmd end \ stat $cstate(storage)]] set cstate(size) [uplevel #0 [linsert $storCmd end \ size $cstate(storage)]] } ::log::log notice \ "pop3d $name $sock login $cstate(name) $storage $cstate(msg)" ::log::log notice "pop3d $name $sock state trans" Respond2Client $name $sock +OK "congratulations" } return |
︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | "[uplevel #0 [linsert $storCmd end \ size $cstate(storage) $msgid]] octets" } else { Respond2Client $name $sock +OK "" } set token [uplevel #0 [linsert $storCmd end get $cstate(storage) $msgid]] | | | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 | "[uplevel #0 [linsert $storCmd end \ size $cstate(storage) $msgid]] octets" } else { Respond2Client $name $sock +OK "" } set token [uplevel #0 [linsert $storCmd end get $cstate(storage) $msgid]] ::log::log debug "pop3d $name $sock transfering data ($token)" if {$limit < 0} { # Full transfer, we can use "copymessage" and avoid # construction in memory (depending on source of token). log::log debug "pop3d $name Transfer $msgid /full" |
︙ | ︙ |
Changes to modules/pop3d/pop3d.test.
︙ | ︙ | |||
20 21 22 23 24 25 26 | testsNeedTcltest 1.0 support { #use comm/comm.tcl comm useTcllibFile devtools/coserv.tcl ; # loads comm too useTcllibFile devtools/dialog.tcl use md5/md5x.tcl md5 | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | testsNeedTcltest 1.0 support { #use comm/comm.tcl comm useTcllibFile devtools/coserv.tcl ; # loads comm too useTcllibFile devtools/dialog.tcl use md5/md5x.tcl md5 use mime/mime-1.6.tcl mime useLocal pop3d_udb.tcl pop3d::udb useLocalKeep pop3d_dbox.tcl pop3d::dbox } testing { useLocalKeep pop3d.tcl pop3d } |
︙ | ︙ | |||
423 424 425 426 427 428 429 | } # ====================================================================== # ====================================================================== # AUTHORIZATION state - Initial state, after the greeting. # Allowed commands: USER, APOP, QUIT, CAPA # Not permitted: PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP | | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 | } # ====================================================================== # ====================================================================== # AUTHORIZATION state - Initial state, after the greeting. # Allowed commands: USER, APOP, QUIT, CAPA # Not permitted: PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP # proc Match {l c res} { global log cstate foreach addr {127.*.*.* ::1} { set cs [string map [list @ADDR $addr] $cstate($c)] if {[string match [list $log($l) $cs] $res]} { return 1 } } |
︙ | ︙ | |||
557 558 559 560 561 562 563 | # ====================================================================== # ====================================================================== # TRANSACTION state - after successful authentication. # Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP, CAPA # Not permitted: USER, PASS, APOP | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 | # ====================================================================== # ====================================================================== # TRANSACTION state - after successful authentication. # Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP, CAPA # Not permitted: USER, PASS, APOP # foreach {n cmd lidx cidx} { 0 {USER foo} 7 4 1 {APOP foo bar} 7 4 2 {QUIT} 1 2 3 {STAT} 8 4 4 {DELE 1} 9 6 |
︙ | ︙ |
Changes to modules/pop3d/pop3d_dbox.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # pop3d_dbox.tcl -- # # Implementation of a simple mailbox database for the pop3 server # Each mailbox is a a directory in a base directory, with each mail # a file in that directory. The mail file contains both headers and # body of the mail. # # Copyright (c) 2002 by Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # pop3d_dbox.tcl -- # # Implementation of a simple mailbox database for the pop3 server # Each mailbox is a a directory in a base directory, with each mail # a file in that directory. The mail file contains both headers and # body of the mail. # # Copyright (c) 2002 by Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require -exact mime 1.6; # tcllib | mime token is result of "get". package require log ; # tcllib | Logging package namespace eval ::pop3d::dbox { # Data storage in the pop3d::dbox module # ------------------------------------- # One array per object containing the db contents. Keyed by user name. # And the information about the last file data was read from. |
︙ | ︙ | |||
53 54 55 56 57 58 59 | # name name of the mailbox database; if null, generate one. # # Results: # name name of the mailbox database created proc ::pop3d::dbox::new {{name ""}} { variable counter | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | # name name of the mailbox database; if null, generate one. # # Results: # name name of the mailbox database created proc ::pop3d::dbox::new {{name ""}} { variable counter if { [llength [info level 0]] == 1 } { incr counter set name "p3dbox${counter}" } if { ![string equal [info commands ::$name] ""] } { return -code error \ |
︙ | ︙ | |||
100 101 102 103 104 105 106 | proc ::pop3d::dbox::DboxProc {name {cmd ""} args} { # Do minimal args checks here if { [llength [info level 0]] == 2 } { return -code error \ "wrong # args: should be \"$name option ?arg arg ...?\"" } | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | proc ::pop3d::dbox::DboxProc {name {cmd ""} args} { # Do minimal args checks here if { [llength [info level 0]] == 2 } { return -code error \ "wrong # args: should be \"$name option ?arg arg ...?\"" } # Split the args into command and args components if { [llength [info commands ::pop3d::dbox::_$cmd]] == 0 } { variable commands set optlist [join $commands ", "] set optlist [linsert $optlist "end-1" "or"] return -code error "bad option \"$cmd\": must be $optlist" } |
︙ | ︙ |
Changes to modules/pop3d/pop3d_dbox.test.
︙ | ︙ | |||
17 18 19 20 21 22 23 | devtools testutilities.tcl] testsNeedTcl 8.5 ;# Required by mime.tcl testsNeedTcltest 1.0 support { use md5/md5x.tcl md5 | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | devtools testutilities.tcl] testsNeedTcl 8.5 ;# Required by mime.tcl testsNeedTcltest 1.0 support { use md5/md5x.tcl md5 use mime/mime-1.6.tcl mime } testing { useLocal pop3d_dbox.tcl pop3d::dbox } # ------------------------------------------------------------------------- # Reduce output generated by the server objects |
︙ | ︙ |
Changes to modules/pop3d/pop3d_udb.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal pop3d_udb.tcl pop3d::udb } # ---------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/practcl/build/buildutil.tcl.
︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 154 155 156 157 158 | set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } } ### # Returns a dictionary describing the local operating system. # Fields return include: # [list_begin itemized] # [item] download - Filesystem path where fossil repositories and source tarballs are downloaded for the current user | > > | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } } ### # Returns a dictionary describing the local operating system. # Fields return include: # [list_begin itemized] # [item] download - Filesystem path where fossil repositories and source tarballs are downloaded for the current user |
︙ | ︙ |
Changes to modules/practcl/build/class/project/tclkit.tcl.
︙ | ︙ | |||
187 188 189 190 191 192 193 194 195 196 197 198 199 200 | error "$statpkg HAS NO VERSION" } # We employ a NULL to prevent the package system from thinking the # package is actually loaded into the interpreter $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] append main_init_script \n [list set ::starkit::static_packages(${statpkg}) $script] if {[dict get $info autoload]} { ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" } else { ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" append main_init_script \n $script | > | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | error "$statpkg HAS NO VERSION" } # We employ a NULL to prevent the package system from thinking the # package is actually loaded into the interpreter $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] append main_init_script \n [list set ::starkit::static_packages(${statpkg}) $script] if {[dict get $info autoload]} { ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" } else { ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" append main_init_script \n $script |
︙ | ︙ |
Changes to modules/practcl/build/class/toolset/gcc.tcl.
︙ | ︙ | |||
152 153 154 155 156 157 158 159 160 161 162 163 164 165 | } return $localsrcdir } Ensemble make::autodetect {} { set srcdir [my define get srcdir] set localsrcdir [my MakeDir $srcdir] if {$localsrcdir eq {}} { set localsrcdir $srcdir } if {$srcdir eq $localsrcdir} { if {![file exists [file join $srcdir tclconfig install-sh]]} { # ensure we have tclconfig with all of the trimmings set teapath {} | > > > | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | } return $localsrcdir } Ensemble make::autodetect {} { set srcdir [my define get srcdir] set localsrcdir [my MakeDir $srcdir] if {$localsrcdir eq {}} { set localsrcdir $srcdir } if {$localsrcdir eq {}} { set localsrcdir $srcdir } if {$srcdir eq $localsrcdir} { if {![file exists [file join $srcdir tclconfig install-sh]]} { # ensure we have tclconfig with all of the trimmings set teapath {} |
︙ | ︙ |
Changes to modules/practcl/build/doctool.tcl.
︙ | ︙ | |||
45 46 47 48 49 50 51 | append result $outline } return $result } ### # Append a line of text to a variable. Optionally apply a string mapping. | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | append result $outline } return $result } ### # Append a line of text to a variable. Optionally apply a string mapping. # arglist: # map {mandatory 0 positional 1} # text {mandatory 1 positional 1} ### proc ::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { |
︙ | ︙ | |||
84 85 86 87 88 89 90 | # # Scan the file # AutoDoc scan_text $content # # Strip the comments from the distribution # puts $fout [::practcl::docstrip $content] # } # # Write out the manual page # set manout [open [file join $moddir module.man] w] | | | | | | | | | 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 | # # Scan the file # AutoDoc scan_text $content # # Strip the comments from the distribution # puts $fout [::practcl::docstrip $content] # } # # Write out the manual page # set manout [open [file join $moddir module.man] w] # dict set arglist header [string map $modmap [::practcl::cat [file join $srcdir manual.txt]]] # dict set arglist footer [string map $modmap [::practcl::cat [file join $srcdir footer.txt]]] # dict set arglist authors $authors # puts $manout [AutoDoc manpage {*}$arglist] # close $manout ### ::oo::class create ::practcl::doctool { constructor {} { my reset } ### # Process an argument list into an informational dict. # This method also understands non-positional # arguments expressed in the notation of Tip 471 # [uri https://core.tcl-lang.org/tips/doc/trunk/tip/479.md]. # [para] # The output will be a dictionary of all of the fields and whether the fields # are [const positional], [const mandatory], and whether they have a # [const default] value. # [para] # example: # my arglist {a b {c 10}} # # > a {positional 1 mandatory 1} b {positional 1 mandatory 1} c {positional 1 mandatory 0 default 10} ### method arglist {arglist} { set result [dict create] foreach arg $arglist { set name [lindex $arg 0] dict set result $name positional 1 dict set result $name mandatory 1 if {$name in {args dictargs}} { switch [llength $arg] { 1 { dict set result $name mandatory 0 |
︙ | ︙ | |||
191 192 193 194 195 196 197 | } else { set firstword [string range $sline 0 [expr {$fwidx-1}]] set restline [string range $sline [expr {$fwidx+1}] end] } if {[string index $firstword end] eq ":"} { set field [string tolower [string trim $firstword -:]] switch $field { | < < < < | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 | } else { set firstword [string range $sline 0 [expr {$fwidx-1}]] set restline [string range $sline [expr {$fwidx+1}] end] } if {[string index $firstword end] eq ":"} { set field [string tolower [string trim $firstword -:]] switch $field { desc { set field description } } if {[string length $restline]} { dict append result $field "$restline\n" } |
︙ | ︙ | |||
368 369 370 371 372 373 374 | if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result Class_Method "${name} $method" $minfo } } else { switch [llength $args] { 1 { | | | | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result Class_Method "${name} $method" $minfo } } else { switch [llength $args] { 1 { set arglist [lindex $args 0] } 0 { set arglist dictargs #set body [lindex $args 0] } default {error "could not interpret method $name {*}$args"} } if {![dict exists $info arglist]} { dict set info arglist [my arglist $arglist] } dict set result Class_Method [string trim $name :] $info } } ### # Process a statement for a tcloo style object method |
︙ | ︙ | |||
399 400 401 402 403 404 405 | if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result method "\"${name} $method\"" $minfo } } else { switch [llength $args] { 1 { | | | | | | | | | 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 420 421 422 423 424 425 426 427 428 429 430 | if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result method "\"${name} $method\"" $minfo } } else { switch [llength $args] { 1 { set arglist [lindex $args 0] } 0 { set arglist dictargs #set body [lindex $args 0] } default {error "could not interpret method $name {*}$args"} } if {![dict exists $info arglist]} { dict set info arglist [my arglist $arglist] } dict set result method "\"[split [string trim $name :] ::]\"" $info } } ### # Process a proc statement ### method keyword.proc {commentblock name arglist} { set info [my comment $commentblock] if {![dict exists $info arglist]} { dict set info arglist [my arglist $arglist] } return $info } ### # Reset the state of the object and its embedded coroutine ### |
︙ | ︙ | |||
527 528 529 530 531 532 533 | ### # Generate the manual page text for a method or proc ### method section.method {keyword method minfo} { set result {} set line "\[call $keyword \[cmd $method\]" | | | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | ### # Generate the manual page text for a method or proc ### method section.method {keyword method minfo} { set result {} set line "\[call $keyword \[cmd $method\]" if {[dict exists $minfo arglist]} { dict for {argname arginfo} [dict get $minfo arglist] { set positional 1 set mandatory 1 set repeating 0 dict with arginfo {} if {$mandatory==0} { append line " \[opt \"" } else { |
︙ | ︙ | |||
666 667 668 669 670 671 672 | ### # Generate the manual page. Returns the completed text suitable for saving in .man file. # The header argument is a block of doctools text to go in before the machine generated # section. footer is a block of doctools text to go in after the machine generated # section. authors is a list of individual authors and emails in the form of AUTHOR EMAIL ?AUTHOR EMAIL?... # | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 | ### # Generate the manual page. Returns the completed text suitable for saving in .man file. # The header argument is a block of doctools text to go in before the machine generated # section. footer is a block of doctools text to go in after the machine generated # section. authors is a list of individual authors and emails in the form of AUTHOR EMAIL ?AUTHOR EMAIL?... # # arglist: # header {mandatory 0 positional 0} # footer {mandatory 0 positional 0} # authors {mandatory 0 positional 0 type list} ### method manpage args { my variable info set map {%version% 0.0 %module% {Your_Module_Here}} |
︙ | ︙ |
Changes to modules/practcl/build/footer.txt.
1 | [vset CATEGORY practcl] | | | 1 2 | [vset CATEGORY practcl] [include ../doctools2base/include/feedback.inc] |
Changes to modules/practcl/build/makeutil.tcl.
︙ | ︙ |
Deleted modules/practcl/practcl.man.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/practcl/practcl.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/profiler/profiler.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal profiler.tcl profiler } proc do {script} { |
︙ | ︙ |
Changes to modules/rc4/rc4.test.
1 2 3 4 5 6 7 8 9 10 | # rc4.test - Copyright (C) 2004 Pat Thoyts <[email protected]> # # $Id: rc4.test,v 1.12 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # rc4.test - Copyright (C) 2004 Pat Thoyts <[email protected]> # # $Id: rc4.test,v 1.12 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal rc4.tcl rc4 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/rcs/rcs.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal rcs.tcl rcs } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/report/report.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use struct/matrix.tcl struct::matrix } testing { useLocal report.tcl report |
︙ | ︙ |
Changes to modules/ripemd/ripemd128.test.
1 2 3 4 5 6 7 8 9 10 | # ripemd128.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: ripemd128.test,v 1.11 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # ripemd128.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: ripemd128.test,v 1.11 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal ripemd128.tcl ripemd128 ::ripemd::ripemd128 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/ripemd/ripemd160.test.
1 2 3 4 5 6 7 8 9 10 | # ripemd160.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: ripemd160.test,v 1.9 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # ripemd160.test - Copyright (C) 2003 Pat Thoyts <[email protected]> # # $Id: ripemd160.test,v 1.9 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal ripemd160.tcl ripemd160 ::ripemd::ripemd160 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/sasl/ntlm.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use base64/base64.tcl base64 useLocal sasl.tcl SASL } testing { |
︙ | ︙ |
Changes to modules/sasl/sasl.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal sasl.tcl SASL } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/sasl/scram.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] #package require tcltest #source [file join devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] #package require tcltest #source [file join devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 support { useLocal sasl.tcl SASL } testing { useLocal scram.tcl SASL::SCRAM |
︙ | ︙ |
Changes to modules/sha1/sha1.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { if {[useTcllibC]} { useLocalKeep sha1.tcl sha1 } else { useLocal sha1.tcl sha1 |
︙ | ︙ |
Changes to modules/sha1/sha1v1.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal sha1v1.tcl sha1 } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/sha1/sha256.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0- testing { if {[useTcllibC]} { useLocalKeep sha256.tcl sha256 ::sha2 } else { useLocal sha256.tcl sha256 ::sha2 } |
︙ | ︙ |
Changes to modules/simulation/random.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 #support { # useLocal random.tcl simulation::random #} testing { useLocal random.tcl simulation::random |
︙ | ︙ |
Changes to modules/smtpd/clients/mail-test.tcl.
1 2 3 4 5 6 7 8 9 | package require mime package require smtp set sndr "tcl-test-script@localhost" set rcpt "tcllib-test@localhost" set msg "This is a sample message send from Tcl.\nAs\ always, let us check the transparency function:\n. <-- there\ should be a dot there.\nBye" | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | package require mime package require smtp set sndr "tcl-test-script@localhost" set rcpt "tcllib-test@localhost" set msg "This is a sample message send from Tcl.\nAs\ always, let us check the transparency function:\n. <-- there\ should be a dot there.\nBye" set tok [mime::.new {} -canonical text/plain -encoding 7bit -string $msg] $tok header set Subject "Testing from Tcl" smtp::sendmessage $tok -servers localhost \ -header [list To $rcpt] \ -header [list From $sndr] $tok .destroy |
Changes to modules/smtpd/smtpd.tcl.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- # @mdgen EXCLUDE: clients/mail-test.tcl package require Tcl 8.3; # tcl minimum version package require logger; # tcllib 1.3 | | | | 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 | # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- # @mdgen EXCLUDE: clients/mail-test.tcl package require Tcl 8.3; # tcl minimum version package require logger; # tcllib 1.3 package require -exact mime 1.6; # tcllib package provide smtpd 1.5 namespace eval ::smtpd { variable version [package present smtpd] variable stopped namespace export start stop configure variable commands if {![info exists commands]} { set commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT HELP} # non-minimal commands HELP VRFY EXPN VERB ETRN DSN } variable extensions if {! [info exists extensions]} { array set extensions { 8BITMIME {} SIZE 0 |
︙ | ︙ | |||
48 49 50 51 52 53 54 | validate_sender {} validate_recipient {} usetls 0 tlsopts {} } set options(banner) "tcllib smtpd $version" } | | | | | | 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 | validate_sender {} validate_recipient {} usetls 0 tlsopts {} } set options(banner) "tcllib smtpd $version" } variable tlsopts {-cadir -cafile -certfile -cipher -command -keyfile -password -request -require -ssl2 -ssl3 -tls1} variable log if {![info exists log]} { set log [logger::init smtpd] ${log}::setlevel warn proc ${log}::stdoutcmd {level text} { variable service puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\ $service $level\] $text" } } variable Help if {![info exists Help]} { array set Help { {} {{Topics:} { HELO MAIL DATA RSET NOOP QUIT} {For more information use "HELP <topic>".}} HELO {{HELO <hostname>} { Introduce yourself.}} MAIL {{MAIL FROM: <sender> [ <parameters> ]} { Specify the sender of the message.} { If using ESMTP there may be additional parameters of the} { form NAME=VALUE.}} DATA {{DATA} { Send your mail message.} { End with a line containing a single dot.}} RSET {{RSET} { Reset the session.}} NOOP {{NOOP} { Command ignored by server.}} QUIT {{QUIT} { Exit SMTP session}} } } } |
︙ | ︙ | |||
177 178 179 180 181 182 183 | # ------------------------------------------------------------------------- # Description: # Start the server on the given interface and port. # proc ::smtpd::start {{myaddr {}} {port 25}} { variable options variable stopped | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | # ------------------------------------------------------------------------- # Description: # Start the server on the given interface and port. # proc ::smtpd::start {{myaddr {}} {port 25}} { variable options variable stopped if {[info exists options(socket)]} { return -code error \ "smtpd service already running on socket $options(socket)" } if {$myaddr != {}} { set options(serveraddr) $myaddr |
︙ | ︙ | |||
245 246 247 248 249 250 251 | if {[catch {eval [cget -validate_host] $client_addr} msg] } { Log notice "access denied for $client_addr:$client_port: $msg" Puts $channel "550 Access denied: $msg" set State(access) denied set accepted false } } | | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 | if {[catch {eval [cget -validate_host] $client_addr} msg] } { Log notice "access denied for $client_addr:$client_port: $msg" Puts $channel "550 Access denied: $msg" set State(access) denied set accepted false } } if {$accepted} { # Accept the connection Log notice "connect from $client_addr:$client_port on $channel" Puts $channel "220 $options(serveraddr) $options(banner); [timestamp]" } return } # ------------------------------------------------------------------------- # Description: # Initialize the channel state array. Called by accept and RSET. # |
︙ | ︙ | |||
487 488 489 490 491 492 493 | # proc ::smtpd::deliver {channel} { set deliverMIME [cget deliverMIME] if { $deliverMIME != {} \ && [state $channel from] != {} \ && [state $channel to] != {} \ && [state $channel data] != {} } { | | | | | | | | | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 | # proc ::smtpd::deliver {channel} { set deliverMIME [cget deliverMIME] if { $deliverMIME != {} \ && [state $channel from] != {} \ && [state $channel to] != {} \ && [state $channel data] != {} } { # create a MIME token from the mail message. set tok [mime::.new {} -string \ [join [state $channel data] \n]] # mime::setheader $tok "From" [state $channel from] # foreach recipient [state $channel to] { # mime::setheader $tok "To" $recipient -mode append # } # catch and rethrow any errors. set err [catch {eval $deliverMIME [list $tok]} msg] $tok .destroy -subordinates all if {$err} { Log debug "error in deliver: $msg" return -code error -errorcode $::errorCode \ -errorinfo $::errorInfo $msg } } else { # Try the old interface deliver_old $channel } } # ------------------------------------------------------------------------- |
︙ | ︙ | |||
655 656 657 658 659 660 661 | Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Specify a recipient for this mail. This command may be executed multiple | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Specify a recipient for this mail. This command may be executed multiple # times to contruct a list of recipients. If a -validate_recipient # procedure is configured then this is used. An error from the validation # procedure indicates an invalid or unacceptable mailbox. # Reference: # RFC2821 4.1.1.3 # Notes: # The postmaster mailbox MUST be supported. (RFC2821: 4.5.1) # |
︙ | ︙ | |||
711 712 713 714 715 716 717 | state $channel to $recipients Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 | state $channel to $recipients Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Begin accepting data for the mail payload. A line containing a single # period marks the end of the data and the server will then deliver the # mail. RCPT and MAIL commands must have been executed before the DATA # command. # Reference: # RFC2821 4.1.1.4 # Notes: # The DATA section is the only part of the protocol permitted to use non- |
︙ | ︙ | |||
831 832 833 834 835 836 837 | # ------------------------------------------------------------------------- # Description: # Terminate a session and close the transmission channel. # Reference: # RFC2821 4.1.1.10 # Notes: | | | | | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | # ------------------------------------------------------------------------- # Description: # Terminate a session and close the transmission channel. # Reference: # RFC2821 4.1.1.10 # Notes: # The server is only permitted to close the channel once it has received # a QUIT message. # proc ::smtpd::QUIT {channel line} { variable options upvar [namespace current]::state_$channel State Log debug "QUIT on $channel" Puts $channel "221 $options(serveraddr) Service closing transmission channel" close $channel # cleanup the session state array. unset State return } # ------------------------------------------------------------------------- # Description: # Implement support for secure mail transactions using the TLS package. # Reference: # RFC3207 # Notes: # proc ::smtpd::STARTTLS {channel line} { variable options upvar [namespace current]::state_$channel State Log debug "$line on $channel" if {![string equal $line STARTTLS]} { Puts $channel "501 Syntax error (no parameters allowed)" return } if {[lsearch -exact $options(tlsopts) -certfile] == -1 || [lsearch -exact $options(tlsopts) -keyfile] == -1} { Puts $channel "454 TLS not available due to temporary reason" return } set import [linsert $options(tlsopts) 0 ::tls::import $channel -server 1] Puts $channel "220 Ready to start TLS" if {[catch $import msg]} { Puts $channel "454 TLS not available due to temporary reason" } else { set State(domain) {}; # RFC3207:4.2 set State(tls) 1 } return } # ------------------------------------------------------------------------- # Logging callback for use with tls - you must specify this when configuring # smtpd if you wan to use it. # proc ::smtpd::tlscallback {option args} { switch -exact -- $option { "error" { foreach {chan msg} $args break Log error "TLS error '$msg'" } "verify" { foreach {chan depth cert rc err} $args break if {$rc ne "1"} { Log error "TLS verify/$depth Bad cert '$err' (rc=$rc)" } else { array set c $cert Log notice "TLS verify/$depth: $c(subject)" |
︙ | ︙ |
Changes to modules/snit/snit.test.
︙ | ︙ | |||
26 27 28 29 30 31 32 | # " ne " -> "!string equal" #----------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | # " ne " -> "!string equal" #----------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.2 #--------------------------------------------------------------------- # Set up a number of constraints. This also determines which # implementation of snit is loaded and tested. # WHD: Work around bugs in 8.5a3 |
︙ | ︙ |
Changes to modules/soundex/soundex.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal soundex.tcl soundex } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/stooop/stooop.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>. # This code may be distributed under the same terms as Tcl. # # $Id: stooop.test,v 1.12 2006/10/09 15:23:06 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>. # This code may be distributed under the same terms as Tcl. # # $Id: stooop.test,v 1.12 2006/10/09 15:23:06 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal stooop.tcl stooop } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/stringprep/stringprep.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocalFile unicode_data.tcl useLocalFile unicode.tcl useLocalFile stringprep_data.tcl useLocalFile stringprep.tcl |
︙ | ︙ |
Changes to modules/stringprep/unicode.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # unicode.test -*- tcl -*- # # Tests for the unicode package. This file is automatically generated by # the gen_unicode_test.tcl script. Do not modify this file by hands. # # RCS: @(#) $Id: unicode.test,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # unicode.test -*- tcl -*- # # Tests for the unicode package. This file is automatically generated by # the gen_unicode_test.tcl script. Do not modify this file by hands. # # RCS: @(#) $Id: unicode.test,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocalFile unicode_data.tcl useLocalFile unicode.tcl } |
︙ | ︙ |
Changes to modules/struct/graph.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useLocal list.tcl struct::list useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set |
︙ | ︙ |
Changes to modules/struct/graph1.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal graph1.tcl struct::graph } # --------------------------------------------------- |
︙ | ︙ |
Changes to modules/struct/list.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testing { useLocal list.tcl struct::list } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/struct/matrix.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # matrix.test: tests for the matrix structure. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2001, 2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # -*- tcl -*- # matrix.test: tests for the matrix structure. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2001, 2019 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testsNeed TclOO 1 support { # memchan allows proper testing of `format 2chan` method. |
︙ | ︙ |
Changes to modules/struct/matrix1.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # matrix.test: tests for the matrix structure. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2001 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # -*- tcl -*- # matrix.test: tests for the matrix structure. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2001 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join [ file dirname [file dirname [file join [pwd] [info script]]] ] devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 testsNeed TclOO 1 support { # memchan allows proper testing of `format 2chan` method. |
︙ | ︙ |
Changes to modules/struct/pkgIndex.tcl.
︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 | package ifneeded struct::matrix 1.2.2 [list source [file join $dir matrix1.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded struct::list 1.8.4 [list source [file join $dir list.tcl]] package ifneeded struct::graph 2.4.3 [list source [file join $dir graph.tcl]] package ifneeded struct::map 1 [list source [file join $dir map.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded struct::disjointset 1.1 [list source [file join $dir disjointset.tcl]] package ifneeded struct::graph::op 0.11.3 [list source [file join $dir graphops.tcl]] | > > > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | package ifneeded struct::matrix 1.2.2 [list source [file join $dir matrix1.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded struct::list 1.8.4 [list source [file join $dir list.tcl]] package ifneeded struct::graph 2.4.3 [list source [file join $dir graph.tcl]] package ifneeded struct::map 1 [list source [file join $dir map.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded struct::disjointset 1.1 [list source [file join $dir disjointset.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded struct::disjointset 1.1 [list source [file join $dir disjointset.tcl]] package ifneeded struct::graph::op 0.11.3 [list source [file join $dir graphops.tcl]] |
Changes to modules/struct/pool.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal pool.tcl struct::pool } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/struct/prioqueue.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal prioqueue.tcl struct::prioqueue } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/struct/queue.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useAccel [useTcllibC] struct/queue.tcl struct::queue TestAccelInit struct::queue } |
︙ | ︙ |
Changes to modules/struct/record.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal record.tcl struct::record } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/struct/sets.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | #---------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | #---------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set } |
︙ | ︙ |
Changes to modules/struct/skiplist.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0- testing { useLocal skiplist.tcl struct::skiplist } #---------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/struct/stack.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useAccel [useTcllibC] struct/stack.tcl struct::stack TestAccelInit struct::stack } |
︙ | ︙ |
Changes to modules/struct/tree.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0- support { useLocal list.tcl struct::list useLocalFile tree/tests/Xsupport } testing { |
︙ | ︙ |
Changes to modules/struct/tree1.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal tree1.tcl struct::tree } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/tepam/adbox_all.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testsNeed Tk 8.3 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } |
︙ | ︙ |
Changes to modules/tepam/adbox_widgets.test.
︙ | ︙ | |||
15 16 17 18 19 20 21 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testsNeed Tk 8.3 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } |
︙ | ︙ |
Changes to modules/tepam/bug_fixes.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } set tepam::named_arguments_first 0 |
︙ | ︙ |
Changes to modules/tepam/doc_gen.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam::doc_gen} catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam useLocal tepam_doc_gen.tcl tepam::doc_gen |
︙ | ︙ |
Changes to modules/tepam/proc_call_arg_nun.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } set tepam::named_arguments_first 1 |
︙ | ︙ |
Changes to modules/tepam/proc_call_arg_type.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } |
︙ | ︙ |
Changes to modules/tepam/proc_call_arg_unn.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } set tepam::named_arguments_first 0 |
︙ | ︙ |
Changes to modules/tepam/proc_call_arg_valid.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } |
︙ | ︙ |
Changes to modules/tepam/proc_interactive.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testsNeed Tk 8.3 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } |
︙ | ︙ |
Changes to modules/tepam/proc_namespaces.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} catch {namespace delete ns1} catch {namespace delete ns2} catch {rename Parent1 ""} catch {rename Child ""} |
︙ | ︙ |
Changes to modules/tepam/proc_subproc.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ########################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 catch {namespace delete ::tepam} testing { useLocal tepam.tcl tepam } |
︙ | ︙ |
Changes to modules/textutil/build/build.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] set fout [open [file join $moddir wcswidth.tcl] w] puts $fout {### # This file is automatically generated by the build/build.tcl file # based on information in the following database: # http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt # # (This is the 35th edition, thus version 35 for our package) # # Author: Sean Woods <[email protected]> ### | | | | 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 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] set fout [open [file join $moddir wcswidth.tcl] w] puts $fout {### # This file is automatically generated by the build/build.tcl file # based on information in the following database: # http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt # # (This is the 35th edition, thus version 35 for our package) # # Author: Sean Woods <[email protected]> ### package provide textutil::wcswidth 35.0} set fin [open [file join $srcdir EastAsianWidth.txt] r] puts $fout "proc ::textutil::wcswidth_type char \{" set hash # while {[gets $fin line]>=0} { set commentidx [string first $hash $line] if {$commentidx==0} continue set data [string trim [string range $line 0 [expr $commentidx-1]]] set comment [string range $line [expr {$commentidx+1}] end] if {[scan $line {%6x..%6x;%1s} start end code]==3} { } elseif {[scan $line {%5x..%5x;%1s} start end code]==3} { } elseif {[scan $line {%4x..%4x;%1s} start end code]==3} { } elseif {[scan $line {%5x;%1s} start code]==2} { set end $start } elseif {[scan $line {%4x;%1s} start code]==2} { set end $start } else { puts "Ignored line $line" continue } if {$code eq "N"} continue dict set map %start% $start dict set map %end% $end dict set map %code% $code dict set map %comment% [string trim $comment] |
︙ | ︙ | |||
58 59 60 61 62 63 64 | } elseif {[scan $line {%5x..%5x;%1s} start end code]==3} { } elseif {[scan $line {%4x..%4x;%1s} start end code]==3} { } elseif {[scan $line {%5x;%1s} start code]==2} { set end $start } elseif {[scan $line {%4x;%1s} start code]==2} { set end $start } else { | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | } elseif {[scan $line {%5x..%5x;%1s} start end code]==3} { } elseif {[scan $line {%4x..%4x;%1s} start end code]==3} { } elseif {[scan $line {%5x;%1s} start code]==2} { set end $start } elseif {[scan $line {%4x;%1s} start code]==2} { set end $start } else { puts "Ignored line $line" continue } dict set map %start% $start dict set map %end% $end dict set map %width% 1 ### |
︙ | ︙ | |||
115 116 117 118 119 120 121 | } puts $fout { return 1} puts $fout "\}" puts $fout { proc ::textutil::wcswidth {string} { set width 0 set len [string length $string] | | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | } puts $fout { return 1} puts $fout "\}" puts $fout { proc ::textutil::wcswidth {string} { set width 0 set len [string length $string] for {set i 0} {$i < $len} {incr i} { scan [string index $string $i] %c char set n [::textutil::wcswidth_char $char] if {$n < 0} { return -1 } incr width $n } return $width } } |
Changes to modules/textutil/wcswidth.tcl.
1 2 3 4 5 6 7 8 9 | ### # This file is automatically generated by the build/build.tcl file # based on information in the following database: # http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt # # (This is the 35th edition, thus version 35 for our package) # # Author: Sean Woods <[email protected]> ### | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ### # This file is automatically generated by the build/build.tcl file # based on information in the following database: # http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt # # (This is the 35th edition, thus version 35 for our package) # # Author: Sean Woods <[email protected]> ### package provide textutil::wcswidth 35.0 proc ::textutil::wcswidth_type char { if {$char == 161} { return A } if {$char == 164} { return A } if {$char == 167} { return A } if {$char == 168} { return A } if {$char == 170} { return A } if {$char == 173} { return A } |
︙ | ︙ | |||
755 756 757 758 759 760 761 | if {$char >= 196608 && $char <= 262141 } { return 2 } return 1 } proc ::textutil::wcswidth {string} { set width 0 set len [string length $string] | | | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 | if {$char >= 196608 && $char <= 262141 } { return 2 } return 1 } proc ::textutil::wcswidth {string} { set width 0 set len [string length $string] for {set i 0} {$i < $len} {incr i} { scan [string index $string $i] %c char set n [::textutil::wcswidth_char $char] if {$n < 0} { return -1 } incr width $n } return $width } |
Changes to modules/tie/tie.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie.test,v 1.11 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie.test,v 1.11 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit use cmdline/cmdline.tcl cmdline } testing { |
︙ | ︙ |
Changes to modules/tie/tie_array.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_array.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_array.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit useLocal tie.tcl tie } testing { |
︙ | ︙ |
Changes to modules/tie/tie_file.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_file.test,v 1.10 2006/10/12 04:45:57 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_file.test,v 1.10 2006/10/12 04:45:57 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit useLocal tie.tcl tie } testing { |
︙ | ︙ |
Changes to modules/tie/tie_growfile.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_growfile.test,v 1.3 2006/10/12 04:45:57 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_growfile.test,v 1.3 2006/10/12 04:45:57 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit useLocal tie.tcl tie } testing { |
︙ | ︙ |
Changes to modules/tie/tie_log.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_log.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_log.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit useLocal tie.tcl tie } testing { |
︙ | ︙ |
Changes to modules/tie/tie_rarray.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_rarray.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Tests for the tie module. -*- tcl -*- # # Copyright (c) 2004 Andreas Kupries <[email protected]> # All rights reserved. # # RCS: @(#) $Id: tie_rarray.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit useLocal tie.tcl tie } testing { |
︙ | ︙ |
Changes to modules/tie/tie_rarray_comm.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use comm/comm.tcl comm use snit/snit.tcl snit use cmdline/cmdline.tcl cmdline useLocal tie.tcl tie |
︙ | ︙ |
Changes to modules/tiff/tiff.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # tiff.test: Tests for the TIFF utilities. # # Copyright (c) 2008 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # tiff.test: Tests for the TIFF utilities. # # Copyright (c) 2008 by Andreas Kupries <[email protected]> # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 # Marks tests which are only for Tk. tcltest::testConstraint tk [info exists tk_version] # Remove constraint from the tests when bug is fixed. # Uncomment next line to run tests with this constraint. |
︙ | ︙ |
Changes to modules/tool/build/build.tcl.
1 2 3 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] | | | 1 2 3 4 5 6 7 8 9 10 11 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] set version 0.7.1 set module [file tail $moddir] set fout [open [file join $moddir ${module}.tcl] w] dict set map %module% $module dict set map %version% $version puts $fout [string map $map {### |
︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | # Track what files we have included so far set loaded {} lappend loaded build.tcl # These files must be loaded in a particular order foreach file { core.tcl uuid.tcl ensemble.tcl metaclass.tcl option.tcl event.tcl pipeline.tcl | > > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | # Track what files we have included so far set loaded {} lappend loaded build.tcl # These files must be loaded in a particular order foreach file { dicttool.tcl dialect.tcl oometa.tcl cron.tcl core.tcl uuid.tcl ensemble.tcl metaclass.tcl option.tcl event.tcl pipeline.tcl |
︙ | ︙ |
Changes to modules/tool/build/core.tcl.
1 | package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. package require coroutine package require TclOO package require sha1 #package require cron 2.0 #package require oo::dialect ::oo::dialect::create ::tool ::namespace eval ::tool {} set ::tool::trace 0 proc ::tool::script_path {} { set path [file dirname [file join [pwd] [info script]]] |
︙ | ︙ |
Added modules/tool/build/cron.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | ### # This file implements a process table # Instead of having individual components try to maintain their own timers # we centrally manage how often tasks should be kicked off here. ### # # Author: Sean Woods (for T&E Solutions) ::namespace eval ::cron {} proc ::cron::task {command args} { if {$::cron::trace > 1} { puts [list ::cron::task $command $args] } variable processTable switch $command { TEMPLATE { return [list object {} lastevent 0 lastrun 0 err 0 result {} \ running 0 coroutine {} scheduled 0 frequency 0 command {}] } delete { unset -nocomplain ::cron::processTable([lindex $args 0]) } exists { return [::info exists ::cron::processTable([lindex $args 0])] } info { set process [lindex $args 0] if {![::info exists ::cron::processTable($process)]} { error "Process $process does not exist" } return $::cron::processTable($process) } frequency { set process [lindex $args 0] set time [lindex $args 1] if {![info exists ::cron::processTable($process)]} return dict with ::cron::processTable($process) { set now [clock_step [current_time]] set frequency [expr {0+$time}] if {$scheduled>($now+$time)} { dict set ::cron::processTable($process) scheduled [expr {$now+$time}] } } } sleep { set process [lindex $args 0] set time [lindex $args 1] if {![info exists ::cron::processTable($process)]} return dict with ::cron::processTable($process) { set now [clock_step [current_time]] set frequency 0 set scheduled [expr {$now+$time}] } } create - set { set process [lindex $args 0] if {![::info exists ::cron::processTable($process)]} { set ::cron::processTable($process) [task TEMPLATE] } if {[llength $args]==2} { foreach {field value} [lindex $args 1] { dict set ::cron::processTable($process) $field $value } } else { foreach {field value} [lrange $args 1 end] { dict set ::cron::processTable($process) $field $value } } } } } proc ::cron::at args { if {$::cron::trace > 1} { puts [list ::cron::at $args] } switch [llength $args] { 2 { variable processuid set process event#[incr processuid] lassign $args timecode command } 3 { lassign $args process timecode command } default { error "Usage: ?process? timecode command" } } variable processTable if {[string is integer -strict $timecode]} { set scheduled [expr {$timecode*1000}] } else { set scheduled [expr {[clock scan $timecode]*1000}] } ::cron::task set $process \ frequency -1 \ command $command \ scheduled $scheduled \ coroutine {} if {$::cron::trace > 1} { puts [list ::cron::task info $process - > [::cron::task info $process]] } ::cron::wake NEW return $process } proc ::cron::idle args { if {$::cron::trace > 1} { puts [list ::cron::idle $args] } switch [llength $args] { 2 { variable processuid set process event#[incr processuid] lassign $args command } 3 { lassign $args process command } default { error "Usage: ?process? timecode command" } } ::cron::task set $process \ scheduled 0 \ frequency 0 \ command $command ::cron::wake NEW return $process } proc ::cron::in args { if {$::cron::trace > 1} { puts [list ::cron::in $args] } switch [llength $args] { 2 { variable processuid set process event#[incr processuid] lassign $args timecode command } 3 { lassign $args process timecode command } default { error "Usage: ?process? timecode command" } } set now [clock_step [current_time]] set scheduled [expr {$timecode*1000+$now}] ::cron::task set $process \ frequency -1 \ command $command \ scheduled $scheduled ::cron::wake NEW return $process } proc ::cron::cancel {process} { if {$::cron::trace > 1} { puts [list ::cron::cancel $process] } ::cron::task delete $process } ### # topic: 0776dccd7e84530fa6412e507c02487c ### proc ::cron::every {process frequency command} { if {$::cron::trace > 1} { puts [list ::cron::every $process $frequency $command] } variable processTable set mnow [clock_step [current_time]] set frequency [expr {$frequency*1000}] ::cron::task set $process \ frequency $frequency \ command $command \ scheduled [expr {$mnow + $frequency}] ::cron::wake NEW } proc ::cron::object_coroutine {objname coroutine {info {}}} { if {$::cron::trace > 1} { puts [list ::cron::object_coroutine $objname $coroutine $info] } task set $coroutine \ {*}$info \ object $objname \ coroutine $coroutine return $coroutine } # Notification that an object has been destroyed, and that # it should give up any toys associated with events proc ::cron::object_destroy {objname} { if {$::cron::trace > 1} { puts [list ::cron::object_destroy $objname] } variable processTable set dat [array get processTable] foreach {process info} $dat { if {[dict exists $info object] && [dict get $info object] eq $objname} { unset -nocomplain processTable($process) } } } ### # topic: 97015814408714af539f35856f85bce6 ### proc ::cron::run process { variable processTable set mnow [clock_step [current_time]] if {[dict exists processTable($process) scheduled] && [dict exists processTable($process) scheduled]>0} { dict set processTable($process) scheduled [expr {$mnow-1000}] } else { dict set processTable($process) lastrun 0 } ::cron::wake PROCESS } proc ::cron::clock_step timecode { return [expr {$timecode-($timecode%1000)}] } proc ::cron::clock_delay {delay} { set now [current_time] set then [clock_step [expr {$delay+$now}]] return [expr {$then-$now}] } # Sleep for X seconds, wake up at the top proc ::cron::clock_sleep {{sec 1} {offset 0}} { set now [current_time] set delay [expr {[clock_delay [expr {$sec*1000}]]+$offset}] sleep $delay } proc ::cron::current_time {} { if {$::cron::time < 0} { return [clock milliseconds] } return $::cron::time } proc ::cron::clock_set newtime { variable time for {} {$time < $newtime} {incr time 100} { uplevel #0 {::cron::do_one_event CLOCK_ADVANCE} } set time $newtime uplevel #0 {::cron::do_one_event CLOCK_ADVANCE} } proc ::cron::once_in_a_while body { set script {set _eventid_ $::cron::current_event} append script $body # Add a safety to allow this while to only execute once per call append script {if {$_eventid_==$::cron::current_event} yield} uplevel 1 [list while 1 $script] } proc ::cron::sleep ms { if {$::cron::trace > 1} { puts [list ::cron::sleep $ms [info coroutine]] } set coro [info coroutine] # When the clock is being externally # controlled, advance the clock when # a sleep is called variable time if {$time >= 0 && $coro eq {}} { ::cron::clock_set [expr {$time+$ms}] return } if {$coro ne {}} { set mnow [current_time] set start $mnow set end [expr {$start+$ms}] set eventid $coro if {$::cron::trace} { puts "::cron::sleep $ms $coro" } # Mark as running task set $eventid scheduled $end coroutine $coro running 1 ::cron::wake WAKE_IN_CORO yield 2 while {$end >= $mnow} { if {$::cron::trace} { puts "::cron::sleep $ms $coro (loop)" } set mnow [current_time] yield 2 } # Mark as not running to resume idle computation task set $eventid running 0 if {$::cron::trace} { puts "/::cron::sleep $ms $coro" } } else { set eventid [incr ::cron::eventcount] set var ::cron::event_#$eventid set $var 0 if {$::cron::trace} { puts "::cron::sleep $ms $eventid waiting for $var" ::after $ms "set $var 1 ; puts \"::cron::sleep - $eventid - FIRED\"" } else { ::after $ms "set $var 1" } ::vwait $var if {$::cron::trace} { puts "/::cron::sleep $ms $eventid" } unset $var } } ### # topic: 21de7bb8db019f3a2fd5a6ae9b38fd55 # description: # Called once per second, and timed to ensure # we run in roughly realtime ### proc ::cron::runTasksCoro {} { ### # Do this forever ### variable processTable variable processing variable all_coroutines variable coroutine_object variable coroutine_busy variable nextevent variable current_event while 1 { incr current_event set lastevent 0 set now [current_time] # Wake me up in 5 minute intervals, just out of principle set nextevent [expr {$now-($now % 300000) + 300000}] set next_idle_event [expr {$now+250}] if {$::cron::trace > 1} { puts [list CRON TASK RUNNER nextevent $nextevent] } ### # Determine what tasks to run this timestep ### set tasks {} set cancellist {} set nexttask {} foreach {process} [lsort -dictionary [array names processTable]] { dict with processTable($process) { if {$::cron::trace > 1} { puts [list CRON TASK RUNNER process $process frequency: $frequency scheduled: $scheduled] } if {$scheduled==0 && $frequency==0} { set lastrun $now set lastevent $now lappend tasks $process } else { if { $scheduled <= $now } { lappend tasks $process if { $frequency < 0 } { lappend cancellist $process } elseif {$frequency==0} { set scheduled 0 if {$::cron::trace > 1} { puts [list CRON TASK RUNNER process $process demoted to idle] } } else { set scheduled [clock_step [expr {$frequency+$lastrun}]] if { $scheduled <= $now } { set scheduled [clock_step [expr {$frequency+$now}]] } if {$::cron::trace > 1} { puts [list CRON TASK RUNNER process $process rescheduled to $scheduled] } } set lastrun $now } set lastevent $now } } } foreach task $tasks { dict set processTable($task) lastrun $now if {[dict exists processTable($task) foreground] && [dict set processTable($task) foreground]} continue if {[dict exists processTable($task) running] && [dict set processTable($task) running]} continue if {$::cron::trace > 2} { puts [list RUNNING $task [task info $task]] } if {[dict exists $processTable($task) coroutine]} { set coro [dict get $processTable($task) coroutine] } else { set coro {} } dict set processTable($task) running 1 if {[dict exists $processTable($task) command]} { set command [dict get $processTable($task) command] } else { set command {} } if {$command eq {} && $coro eq {}} { # Task has nothing to do. Slot it for destruction lappend cancellist $task } elseif {$coro ne {}} { if {[info command $coro] eq {}} { set object [dict get $processTable($task) object] # Trigger coroutine again if a command was given # If this coroutine is associated with an object, ensure # the object still exists before invoking its method if {$command eq {} || ($object ne {} && [info command $object] eq {})} { lappend cancellist $task dict set processTable($task) running 0 continue } if {$::cron::trace} { puts [list RESTARTING $task - coroutine $coro - with $command] } ::coroutine $coro {*}$command } try $coro on return {} { # Terminate the coroutine lappend cancellist $task } on break {} { # Terminate the coroutine lappend cancellist $task } on error {errtxt errdat} { # Coroutine encountered an error lappend cancellist $task puts "ERROR $coro" set errorinfo [dict get $errdat -errorinfo] if {[info exists coroutine_object($coro)] && $coroutine_object($coro) ne {}} { catch { puts "OBJECT: $coroutine_object($coro)" puts "CLASS: [info object class $coroutine_object($coro)]" } } puts "$errtxt" puts *** puts $errorinfo } on continue {result opts} { # Ignore continue if { $result eq "done" } { lappend cancellist $task } } on ok {result opts} { if { $result eq "done" } { lappend cancellist $task } } } else { dict with processTable($task) { set err [catch {uplevel #0 $command} result errdat] if $err { puts "CRON TASK FAILURE:" puts "PROCESS: $task" puts $result puts *** puts [dict get $errdat -errorinfo] } } yield 0 } dict set processTable($task) running 0 } foreach {task} $cancellist { unset -nocomplain processTable($task) } foreach {process} [lsort -dictionary [array names processTable]] { set scheduled 0 set frequency 0 dict with processTable($process) { if {$scheduled==0 && $frequency==0} { if {$next_idle_event < $nextevent} { set nexttask $task set nextevent $next_idle_event } } elseif {$scheduled < $nextevent} { set nexttask $process set nextevent $scheduled } set lastevent $now } } foreach {eventid msec} [array get ::cron::coro_sleep] { if {$msec < 0} continue if {$msec<$nextevent} { set nexttask "CORO $eventid" set nextevent $scheduled } } set delay [expr {$nextevent-$now}] if {$delay <= 0} { yield 0 } else { if {$::cron::trace > 1} { puts "NEXT EVENT $delay - NEXT TASK $nexttask" } yield $delay } } } proc ::cron::wake {{who ???}} { ## # Only triggered by cron jobs kicking off other cron jobs within # the script body ## if {$::cron::trace} { puts "::cron::wake $who" } if {$::cron::busy} { return } after cancel $::cron::next_event set ::cron::next_event [after idle [list ::cron::do_one_event $who]] } proc ::cron::do_one_event {{who ???}} { if {$::cron::trace} { puts "::cron::do_one_event $who" } after cancel $::cron::next_event set now [current_time] set ::cron::busy 1 while {$::cron::busy} { if {[info command ::cron::COROUTINE] eq {}} { ::coroutine ::cron::COROUTINE ::cron::runTasksCoro } set cron_delay [::cron::COROUTINE] if {$cron_delay==0} { if {[incr loops]>10} { if {$::cron::trace} { puts "Breaking out of 10 recursive loops" } set ::cron::wake_time 1000 break } set ::cron::wake_time 0 incr ::cron::loops(active) } else { set ::cron::busy 0 incr ::cron::loops(idle) } } ### # Try to get the event to fire off on the border of the # nearest second ### if {$cron_delay < 10} { set cron_delay 250 } set ctime [current_time] set next [expr {$ctime+$cron_delay}] set ::cron::wake_time [expr {$next/1000}] if {$::cron::trace} { puts [list EVENT LOOP WILL WAKE IN $cron_delay ms next: [clock format $::cron::wake_time -format "%H:%M:%S"] active: $::cron::loops(active) idle: $::cron::loops(idle) woken_by: $who] } set ::cron::next_event [after $cron_delay {::cron::do_one_event TIMER}] } proc ::cron::main {} { # Never launch from a coroutine if {[info coroutine] ne {}} { return } set ::cron::forever 1 while {$::cron::forever} { ::after 120000 {set ::cron::forever 1} # Call an update just to give the rest of the event loop a chance incr ::cron::loops(main) ::after cancel $::cron::next_event set ::cron::next_event [::after idle {::cron::wake MAIN}] set ::cron::forever 1 set ::cron::busy 0 ::vwait ::cron::forever if {$::cron::trace} { puts "MAIN LOOP CYCLE $::cron::loops(main)" } } } ### # topic: 4a891d0caabc6e25fbec9514ea8104dd # description: # This file implements a process table # Instead of having individual components try to maintain their own timers # we centrally manage how often tasks should be kicked off here. ### namespace eval ::cron { variable lastcall 0 variable processTable variable busy 0 variable next_event {} variable trace 0 variable current_event variable time -1 if {![info exists current_event]} { set current_event 0 } if {![info exists ::cron::loops]} { array set ::cron::loops { active 0 main 0 idle 0 wake 0 } } } ::cron::wake STARTUP |
Added modules/tool/build/dialect.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | ### # oodialect.tcl # # Copyright (c) 2015-2018 Sean Woods # Copyright (c) 2015 Donald K Fellows # # BSD License ### # @@ Meta Begin # Package oo::dialect 0.3.4 # Meta platform tcl # Meta summary A utility for defining a domain specific language for TclOO systems # Meta description This package allows developers to generate # Meta description domain specific languages to describe TclOO # Meta description classes and objects. # Meta category TclOO # Meta subject oodialect # Meta require {Tcl 8.6} # Meta author Sean Woods # Meta author Donald K. Fellows # Meta license BSD # @@ Meta End namespace eval ::oo::dialect { namespace export create } # A stack of class names proc ::oo::dialect::Push {class} { ::variable class_stack lappend class_stack $class } proc ::oo::dialect::Peek {} { ::variable class_stack return [lindex $class_stack end] } proc ::oo::dialect::Pop {} { ::variable class_stack set class_stack [lrange $class_stack 0 end-1] } ### # This proc will generate a namespace, a "mother of all classes", and a # rudimentary set of policies for this dialect. ### proc ::oo::dialect::create {name {parent ""}} { set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name] ::namespace eval $NSPACE {::namespace eval define {}} ### # Build the "define" namespace ### if {$parent eq ""} { ### # With no "parent" language, begin with all of the keywords in # oo::define ### foreach command [info commands ::oo::define::*] { set procname [namespace tail $command] interp alias {} ${NSPACE}::define::$procname {} \ ::oo::dialect::DefineThunk $procname } # Create an empty dynamic_methods proc proc ${NSPACE}::dynamic_methods {class} {} namespace eval $NSPACE { ::namespace export dynamic_methods ::namespace eval define {::namespace export *} } set ANCESTORS {} } else { ### # If we have a parent language, that language already has the # [oo::define] keywords as well as additional keywords and behaviors. # We should begin with that ### set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent] apply [list parent { ::namespace export dynamic_methods ::namespace import -force ${parent}::dynamic_methods } $NSPACE] $pnspace apply [list parent { ::namespace import -force ${parent}::define::* ::namespace export * } ${NSPACE}::define] $pnspace set ANCESTORS [list ${pnspace}::object] } ### # Build our dialect template functions ### proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] { ### # To facilitate library reloading, allow # a dialect to create a class from DEFINE ### set class [::oo::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass] if {[info commands $class] eq {}} { %NSPACE%::class create $class {*}${args} } else { ::oo::dialect::Define %NSPACE% $class {*}${args} } }] interp alias {} ${NSPACE}::define::current_class {} \ ::oo::dialect::Peek interp alias {} ${NSPACE}::define::aliases {} \ ::oo::dialect::Aliases $NSPACE interp alias {} ${NSPACE}::define::superclass {} \ ::oo::dialect::SuperClass $NSPACE if {[info command ${NSPACE}::class] ne {}} { ::rename ${NSPACE}::class {} } ### # Build the metaclass for our language ### ::oo::class create ${NSPACE}::class { superclass ::oo::dialect::MotherOfAllMetaClasses } # Wire up the create method to add in the extra argument we need; the # MotherOfAllMetaClasses will know what to do with it. ::oo::objdefine ${NSPACE}::class \ method create {name {definitionScript ""}} \ "next \$name [list ${NSPACE}::define] \$definitionScript" ### # Build the mother of all classes. Note that $ANCESTORS is already # guaranteed to be a list in canonical form. ### uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { %NSPACE%::class create %NSPACE%::object { superclass %ANCESTORS% # Put MOACish stuff in here } }] if { "${NSPACE}::class" ni $::oo::dialect::core_classes } { lappend ::oo::dialect::core_classes "${NSPACE}::class" } if { "${NSPACE}::object" ni $::oo::dialect::core_classes } { lappend ::oo::dialect::core_classes "${NSPACE}::object" } } # Support commands; not intended to be called directly. proc ::oo::dialect::NSNormalize {namespace qualname} { if {![string match ::* $qualname]} { set qualname ${namespace}::$qualname } regsub -all {::+} $qualname "::" } proc ::oo::dialect::DefineThunk {target args} { tailcall ::oo::define [Peek] $target {*}$args } proc ::oo::dialect::Canonical {namespace NSpace class} { namespace upvar $namespace cname cname #if {[string match ::* $class]} { # return $class #} if {[info exists cname($class)]} { return $cname($class) } if {[info exists ::oo::dialect::cname($class)]} { return $::oo::dialect::cname($class) } if {[info exists ::oo::dialect::cname(${NSpace}::${class})]} { return $::oo::dialect::cname(${NSpace}::${class}) } foreach item [list "${NSpace}::$class" "::$class"] { if {[info commands $item] ne {}} { return $item } } return ${NSpace}::$class } ### # Implementation of the languages' define command ### proc ::oo::dialect::Define {namespace class args} { Push $class try { if {[llength $args]==1} { namespace eval ${namespace}::define [lindex $args 0] } else { ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end] } ${namespace}::dynamic_methods $class } finally { Pop } } ### # Implementation of how we specify the other names that this class will answer # to ### proc ::oo::dialect::Aliases {namespace args} { set class [Peek] namespace upvar $namespace cname cname set NSpace [join [lrange [split $class ::] 1 end-2] ::] set cname($class) $class foreach name $args { set cname($name) $class #set alias $name set alias [NSNormalize $NSpace $name] # Add a local metaclass reference if {![info exists ::oo::dialect::cname($alias)]} { lappend ::oo::dialect::aliases($class) $alias ## # Add a global reference, first come, first served ## set ::oo::dialect::cname($alias) $class } } } ### # Implementation of a superclass keyword which will enforce the inheritance of # our language's mother of all classes ### proc ::oo::dialect::SuperClass {namespace args} { set class [Peek] namespace upvar $namespace class_info class_info dict set class_info($class) superclass 1 set ::oo::dialect::cname($class) $class set NSpace [join [lrange [split $class ::] 1 end-2] ::] set unique {} foreach item $args { set Item [Canonical $namespace $NSpace $item] dict set unique $Item $item } set root ${namespace}::object if {$class ne $root} { dict set unique $root $root } tailcall ::oo::define $class superclass {*}[dict keys $unique] } ### # Implementation of the common portions of the the metaclass for our # languages. ### if {[info commands ::oo::dialect::MotherOfAllMetaClasses] eq {}} { ::oo::class create ::oo::dialect::MotherOfAllMetaClasses { superclass ::oo::class constructor {define definitionScript} { $define [self] { superclass } $define [self] $definitionScript } method aliases {} { if {[info exists ::oo::dialect::aliases([self])]} { return $::oo::dialect::aliases([self]) } } } } namespace eval ::oo::dialect { variable core_classes {::oo::class ::oo::object} } |
Added modules/tool/build/dicttool.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ### # This package enhances the stock dict implementation with some # creature comforts ### if {[info commands ::ladd] eq {}} { proc ladd {varname args} { upvar 1 $varname var if ![info exists var] { set var {} } foreach item $args { if {$item in $var} continue lappend var $item } return $var } } if {[info command ::ldelete] eq {}} { proc ::ldelete {varname args} { upvar 1 $varname var if ![info exists var] { return } foreach item [lsort -unique $args] { while {[set i [lsearch $var $item]]>=0} { set var [lreplace $var $i $i] } } return $var } } if {[::info commands ::tcl::dict::getnull] eq {}} { proc ::tcl::dict::getnull {dictionary args} { if {[exists $dictionary {*}$args]} { get $dictionary {*}$args } } namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull] } if {[::info commands ::tcl::dict::print] eq {}} { ### # Test if element is a dict ### proc ::tcl::dict::_putb {buffervar indent field value} { ::upvar 1 $buffervar buffer ::append buffer \n [::string repeat " " $indent] [::list $field] " " if {[string index $field end] eq "/"} { ::incr indent 2 ::append buffer "\{" foreach item $value { if [catch { if {![is_dict $item]} { ::append buffer \n [::string repeat " " $indent] [list $item] } else { ::append buffer \n "[::string repeat " " $indent]\{" ::incr indent 2 foreach {sf sv} $item { _putb buffer $indent $sf $sv } ::incr indent -2 ::append buffer \n "[::string repeat " " $indent]\}" } } err] { puts [list FAILED $indent $field $item] puts $err puts "$::errorInfo" } } ::incr indent -2 ::append buffer \n [::string repeat " " $indent] "\}" } elseif {[string index $field end] eq ":" || ![is_dict $value]} { ::append buffer [::list $value] } else { ::incr indent 2 ::append buffer "\{" foreach {f v} $value { _putb buffer $indent $f $v } ::incr indent -2 ::append buffer \n [::string repeat " " $indent] "\}" } } proc ::tcl::dict::print dict { ::set buffer {} ::foreach {field value} $dict { _putb buffer 0 $field $value } return $buffer } namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] print ::tcl::dict::print] } if {[::info commands ::tcl::dict::is_dict] eq {}} { ### # Test if element is a dict ### proc ::tcl::dict::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict] } if {[::info commands ::tcl::dict::rmerge] eq {}} { ### # title: A recursive form of dict merge # description: # A routine to recursively dig through dicts and merge # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/ ### proc ::tcl::dict::rmerge {a args} { ::set result $a # Merge b into a, and handle nested dicts appropriately ::foreach b $args { for { k v } $b { if {[string index $k end] eq ":"} { # Element names that end in ":" are assumed to be literals set result $k $v } elseif { [dict exists $result $k] } { # key exists in a and b? let's see if both values are dicts # both are dicts, so merge the dicts if { [is_dict [get $result $k]] && [is_dict $v] } { set result $k [rmerge [get $result $k] $v] } else { set result $k $v } } else { set result $k $v } } } return $result } namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge] } if {[::info commands ::tcl::dict::isnull] eq {}} { proc ::tcl::dict::isnull {dictionary args} { if {![exists $dictionary {*}$args]} {return 1} return [expr {[get $dictionary {*}$args] in {{} NULL null}}] } namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull] } |
Changes to modules/tool/build/metaclass.tcl.
1 | #------------------------------------------------------------------------- | | | 1 2 3 4 5 6 7 8 9 | #------------------------------------------------------------------------- # TITLE: # tool.tcl # # PROJECT: # tool: TclOO Helper Library # # DESCRIPTION: # tool(n): Implementation File |
︙ | ︙ | |||
321 322 323 324 325 326 327 | variable mixins {} variable mixinmap {} variable DestroyEvent 0 constructor args { my Config_merge [::tool::args_to_options {*}$args] } | | | | | | | | | 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 | variable mixins {} variable mixinmap {} variable DestroyEvent 0 constructor args { my Config_merge [::tool::args_to_options {*}$args] } destructor {} method ancestors {{reverse 0}} { set result [::oo::meta::ancestors [info object class [self]]] if {$reverse} { return [lreverse $result] } return $result } method DestroyEvent {} { my variable DestroyEvent return $DestroyEvent } ### # title: Forward a method ### method forward {method args} { oo::objdefine [self] forward $method {*}$args } ### # title: Direct a series of sub-functions to a seperate object ### method graft args { my variable organs if {[llength $args] == 1} { error "Need two arguments" } set object {} foreach {stub object} $args { if {$stub eq "class"} { # Force class to always track the object's current class set obj [info object class [self]] } dict set organs $stub $object oo::objdefine [self] forward <${stub}> $object oo::objdefine [self] export <${stub}> } return $object } # Called after all options and public variables are initialized method initialize {} {} ### # topic: 3c4893b65a1c79b2549b9ee88f23c9e3 # description: # Provide a default value for all options and # publically declared variables, and locks the # pipeline mutex to prevent signal processing # while the contructor is still running. |
︙ | ︙ | |||
389 390 391 392 393 394 395 | # publically declared variables, and locks the # pipeline mutex to prevent signal processing # while the contructor is still running. # Note, by default an odie object will ignore # signals until a later call to <i>my lock remove pipeline</i> ### method InitializePublic {} { | | > > > > > > | | 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 | # publically declared variables, and locks the # pipeline mutex to prevent signal processing # while the contructor is still running. # Note, by default an odie object will ignore # signals until a later call to <i>my lock remove pipeline</i> ### method InitializePublic {} { my variable config meta mixinmap mixins if {![info exists mixins]} { set mixins {} } if {![info exists mixinmap]} { set mixinmap {} } if {![info exists meta]} { set meta {} } if {![info exists config]} { set config {} } my ClassPublicApply {} } class_method info {which} { my variable cache if {![info exists cache($which)]} { set cache($which) {} switch $which { public { dict set cache(public) variable [my meta branchget variable] |
︙ | ︙ | |||
428 429 430 431 432 433 434 | dict set cache(public) option_canonical $var $var } } } } return $cache($which) } | | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | dict set cache(public) option_canonical $var $var } } } } return $cache($which) } ### # Incorporate the class's variables, arrays, and options ### method ClassPublicApply class { my variable config set integrate 0 if {$class eq {}} { set class [info object class [self]] } else { set integrate 1 } set public [$class info public] foreach {var value} [dict getnull $public variable] { if { $var in {meta config} } continue my variable $var |
︙ | ︙ | |||
490 491 492 493 494 495 496 | set script [dict getnull $dat $field set-command:] dict set config $field $val if {$script ne {}} { {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script] } } } | | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 | set script [dict getnull $dat $field set-command:] dict set config $field $val if {$script ne {}} { {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script] } } } ### # topic: 3c4893b65a1c79b2549b9ee88f23c9e3 # description: # Provide a default value for all options and # publically declared variables, and locks the # pipeline mutex to prevent signal processing # while the contructor is still running. |
︙ | ︙ | |||
524 525 526 527 528 529 530 | foreach class $args { if {$class ni $prior} { my meta mixin $class } my ClassPublicApply $class } foreach class $prior { | | | | | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | foreach class $args { if {$class ni $prior} { my meta mixin $class } my ClassPublicApply $class } foreach class $prior { if {$class ni $mixins } { my meta mixout $class } } } method mixinmap args { my variable mixinmap set priorlist {} foreach {slot classes} $args { if {[dict exists $mixinmap $slot]} { lappend priorlist {*}[dict get $mixinmap $slot] foreach class [dict get $mixinmap $slot] { if {$class ni $classes && [$class meta exists mixin unmap-script:]} { if {[catch [$class meta get mixin unmap-script:] err errdat]} { puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]" } } } |
︙ | ︙ | |||
582 583 584 585 586 587 588 | foreach {item class} $mixinmap { if {$class ne {}} { lappend classlist $class } } my mixin {*}$classlist } | | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 | foreach {item class} $mixinmap { if {$class ne {}} { lappend classlist $class } } my mixin {*}$classlist } method morph newclass { if {$newclass eq {}} return set class [string trimleft [info object class [self]]] set newclass [string trimleft $newclass :] if {[info command ::$newclass] eq {}} { error "Class $newclass does not exist" } |
︙ | ︙ | |||
610 611 612 613 614 615 616 | # Commands to perform as this object transitions out of the present class ### method Morph_leave {} {} ### # Commands to perform as this object transitions into this class as a new class ### method Morph_enter {} {} | | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 | # Commands to perform as this object transitions out of the present class ### method Morph_leave {} {} ### # Commands to perform as this object transitions into this class as a new class ### method Morph_enter {} {} ### # title: List which objects are forwarded as organs ### method organ {{stub all}} { my variable organs if {![info exists organs]} { return {} |
︙ | ︙ |
Added modules/tool/build/oometa.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 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 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 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 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 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | namespace eval ::oo::meta { set dirty_classes {} } proc ::oo::meta::args_to_dict args { if {[llength $args]==1} { return [lindex $args 0] } return $args } proc ::oo::meta::args_to_options args { set result {} foreach {var val} [args_to_dict {*}$args] { lappend result [string trimleft $var -] $val } return $result } proc ::oo::meta::ancestors class { set class [::oo::meta::normalize $class] set core_result {} set queue $class set result {} # Rig things such that that the top superclasses # are evaluated first while {[llength $queue]} { set tqueue $queue set queue {} foreach qclass $tqueue { if {$qclass in $::oo::dialect::core_classes} { if {$qclass ni $core_result} { lappend core_result $qclass } continue } foreach aclass [::info class superclasses $qclass] { if { $aclass in $result } continue if { $aclass in $core_result } continue if { $aclass in $queue } continue lappend queue $aclass } } foreach item $tqueue { if {$item in $core_result} continue if { $item ni $result } { set result [linsert $result 0 $item] } } } # Handle core classes last set queue $core_result while {[llength $queue]} { set tqueue $queue set queue {} foreach qclass $tqueue { foreach aclass [::info class superclasses $qclass] { if { $aclass in $result } continue if { $aclass in $queue } continue lappend queue $aclass } } foreach item $tqueue { if { $item ni $result } { set result [linsert $result 0 $item] } } } return $result } proc oo::meta::info {class submethod args} { set class [::oo::meta::normalize $class] switch $submethod { cget { ### # submethod: cget # arguments: ?*path* ...? *field* # format: markdown # description: # Retrieve a value from the class' meta data. Values are searched in the # following order: # 1. From class meta data as const **path** **field:** # 2. From class meta data as const **path** **field** # 3. From class meta data as **path** **field:** # 4. From class meta data as **path** **field** ### set path [lrange $args 0 end-1] set field [string trimright [lindex $args end] :] foreach mclass [lreverse [::oo::meta::ancestors $class]] { if {![::info exists ::oo::meta::local_property($mclass)]} continue set class_metadata $::oo::meta::local_property($mclass) if {[dict exists $class_metadata const {*}$path $field:]} { return [dict get $class_metadata const {*}$path $field:] } if {[dict exists $class_metadata const {*}$path $field]} { return [dict get $class_metadata const {*}$path $field] } if {[dict exists $class_metadata {*}$path $field:]} { return [dict get $class_metadata {*}$path $field:] } if {[dict exists $class_metadata {*}$path $field]} { return [dict get $class_metadata {*}$path $field] } } return {} } rebuild { ::oo::meta::rebuild $class } is { set info [metadata $class] return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]] } for - map { set info [metadata $class] uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]] } with { upvar 1 TEMPVAR info set info [metadata $class] return [uplevel 1 [list ::dict with TEMPVAR {*}$args]] } branchget { set info [metadata $class] set result {} foreach {field value} [dict getnull $info {*}$args] { dict set result [string trimright $field :] $value } return $result } branchset { ::oo::meta::rebuild $class foreach {field value} [lindex $args end] { ::dict set ::oo::meta::local_property($class) {*}[lrange $args 0 end-1] [string trimright $field :]: $value } } leaf_add { if {[::info exists ::oo::meta::local_property($class)]} { set result [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]] } ladd result {*}[lrange $args 1 end] dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result } leaf_remove { if {![::info exists ::oo::meta::local_property($class)]} return set result {} forearch element [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]] { if { $element in [lrange $args 1 end]} continue lappend result $element } dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result } append - incr - lappend - set - unset - update { ::oo::meta::rebuild $class ::dict $submethod ::oo::meta::local_property($class) {*}$args } merge { ::oo::meta::rebuild $class set ::oo::meta::local_property($class) [dict rmerge $::oo::meta::local_property($class) {*}$args] } dump { set info [metadata $class] return $info } default { set info [metadata $class] return [::dict $submethod $info {*}$args] } } } proc ::oo::meta::localdata {class args} { if {![::info exists ::oo::meta::local_property($class)]} { return {} } if {[::llength $args]==0} { return $::oo::meta::local_property($class) } return [::dict getnull $::oo::meta::local_property($class) {*}$args] } proc ::oo::meta::normalize class { set class ::[string trimleft $class :] } proc ::oo::meta::metadata {class {force 0}} { set class [::oo::meta::normalize $class] ### # Destroy the cache of all derivitive classes ### if {$force} { unset -nocomplain ::oo::meta::cached_property unset -nocomplain ::oo::meta::cached_hierarchy } else { variable dirty_classes foreach dclass $dirty_classes { foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] { if {$dclass in $cancestors} { unset -nocomplain ::oo::meta::cached_property($cclass) unset -nocomplain ::oo::meta::cached_hierarchy($cclass) } } if {![::info exists ::oo::meta::local_property($dclass)]} continue if {[dict getnull $::oo::meta::local_property($dclass) classinfo type:] eq "core"} { if {$dclass ni $::oo::dialect::core_classes} { lappend ::oo::dialect::core_classes $dclass } } } set dirty_classes {} } ### # If the cache is available, use it ### variable cached_property if {[::info exists cached_property($class)]} { return $cached_property($class) } ### # Build a cache of the hierarchy and the # aggregate metadata for this class and store # them for future use ### variable cached_hierarchy set metadata {} set stack {} variable local_property set cached_hierarchy($class) [::oo::meta::ancestors $class] foreach class $cached_hierarchy($class) { if {[::info exists local_property($class)]} { lappend metadata $local_property($class) } } #foreach aclass [lreverse [::info class superclasses $class]] { # lappend metadata [::oo::meta::metadata $aclass] #} lappend metadata {classinfo {type: {}}} if {[::info exists local_property($class)]} { lappend metadata $local_property($class) } set metadata [dict rmerge {*}$metadata] set cached_property($class) $metadata return $metadata } proc ::oo::meta::rebuild args { foreach class $args { if {$class ni $::oo::meta::dirty_classes} { lappend ::oo::meta::dirty_classes $class } } } proc ::oo::meta::search args { variable local_property set path [lrange $args 0 end-1] set value [lindex $args end] set result {} foreach {class info} [array get local_property] { if {[dict exists $info {*}$path:]} { if {[string match [dict get $info {*}$path:] $value]} { lappend result $class } continue } if {[dict exists $info {*}$path]} { if {[string match [dict get $info {*}$path] $value]} { lappend result $class } } } return $result } proc ::oo::define::meta {args} { set class [lindex [::info level -1] 1] if {[lindex $args 0] in "cget set branchset"} { ::oo::meta::info $class {*}$args } else { ::oo::meta::info $class set {*}$args } } oo::define oo::class { method meta {submethod args} { tailcall ::oo::meta::info [self] $submethod {*}$args } } oo::define oo::object { ### # title: Provide access to meta data # format: markdown # description: # The *meta* method allows an object access # to a combination of its own meta data as # well as to that of its class ### method meta {submethod args} { my variable meta MetaMixin if {![info exists MetaMixin]} { set MetaMixin {} } set class [::info object class [self object]] set classlist [list $class {*}$MetaMixin] switch $submethod { cget { ### # submethod: cget # arguments: ?*path* ...? *field* # format: markdown # description: # Retrieve a value from the local objects **meta** dict # or from the class' meta data. Values are searched in the # following order: # 0. (If path length==1) From the _config array # 1. From the local dict as **path** **field:** # 2. From the local dict as **path** **field** # 3. From class meta data as const **path** **field:** # 4. From class meta data as const **path** **field** # 5. From class meta data as **path** **field:** # 6. From class meta data as **path** **field** ### set path [lrange $args 0 end-1] set field [string trim [lindex $args end] :] if {[dict exists $meta {*}$path $field:]} { return [dict get $meta {*}$path $field:] } if {[dict exists $meta {*}$path $field]} { return [dict get $meta {*}$path $field] } foreach mclass [lreverse $classlist] { set class_metadata [::oo::meta::metadata $mclass] if {[dict exists $class_metadata const {*}$path $field:]} { return [dict get $class_metadata const {*}$path $field:] } if {[dict exists $class_metadata const {*}$path $field]} { return [dict get $class_metadata const {*}$path $field] } if {[dict exists $class_metadata {*}$path $field:]} { return [dict get $class_metadata {*}$path $field:] } if {[dict exists $class_metadata {*}$path $field]} { return [dict get $class_metadata {*}$path $field] } } return {} } is { set value [my meta cget {*}[lrange $args 1 end]] return [string is [lindex $args 0] -strict $value] } for - map { foreach mclass $classlist { lappend mdata [::oo::meta::metadata $mclass] } set info [dict rmerge {*}$mdata $meta] uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]] } with { upvar 1 TEMPVAR info foreach mclass $classlist { lappend mdata [::oo::meta::metadata $mclass] } set info [dict rmerge {*}$mdata $meta] return [uplevel 1 [list dict with TEMPVAR {*}$args]] } dump { foreach mclass $classlist { lappend mdata [::oo::meta::metadata $mclass] } return [dict rmerge {*}$mdata $meta] } append - incr - lappend - set - unset - update { return [dict $submethod meta {*}$args] } branchset { foreach {field value} [lindex $args end] { dict set meta {*}[lrange $args 0 end-1] [string trimright $field :]: $value } } rmerge - merge { set meta [dict rmerge $meta {*}$args] return $meta } exists { foreach mclass $classlist { if {[dict exists [::oo::meta::metadata $mclass] {*}$args]} { return 1 } } if {[dict exists $meta {*}$args]} { return 1 } return 0 } get - getnull { if {[string index [lindex $args end] end]==":"} { # Looking for a leaf node if {[dict exists $meta {*}$args]} { return [dict get $meta {*}$args] } foreach mclass [lreverse $classlist] { set mdata [::oo::meta::metadata $mclass] if {[dict exists $mdata {*}$args]} { return [dict get $mdata {*}$args] } } if {$submethod == "get"} { error "key \"$args\" not known in metadata" } return {} } # Looking for a branch node # So we need to composite the result set found 0 foreach mclass $classlist { set mdata [::oo::meta::metadata $mclass] if {[dict exists $mdata {*}$args]} { set found 1 lappend result [dict get $mdata {*}$args] } } if {[dict exists $meta {*}$args]} { set found 1 lappend result [dict get $meta {*}$args] } if {!$found} { if {$submethod == "get"} { error "key \"$args\" not known in metadata" } return {} } return [dict rmerge {*}$result] } branchget { set result {} foreach mclass [lreverse $classlist] { foreach {field value} [dict getnull [::oo::meta::metadata $mclass] {*}$args] { dict set result [string trimright $field :] $value } } foreach {field value} [dict getnull $meta {*}$args] { dict set result [string trimright $field :] $value } return $result } mixin { foreach mclass $args { set mclass [::oo::meta::normalize $mclass] if {$mclass ni $MetaMixin} { lappend MetaMixin $mclass } } } mixout { foreach mclass $args { set mclass [::oo::meta::normalize $mclass] while {[set i [lsearch $MetaMixin $mclass]]>=0} { set MetaMixin [lreplace $MetaMixin $i $i] } } } default { foreach mclass $classlist { lappend mdata [::oo::meta::metadata $mclass] } set info [dict rmerge {*}$mdata $meta] return [dict $submethod $info {*}$args] } } } } |
Changes to modules/tool/build/script.tcl.
︙ | ︙ |
Changes to modules/tool/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.6]} {return} | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded tool 0.7.1 [list source [file join $dir tool.tcl]] |
Deleted modules/tool/tool.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/tool/tool.test.
1 2 3 4 5 6 7 8 9 10 11 | # tool.test - Copyright (c) 2015 Sean Woods # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2 testsNeed TclOO 1 | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # tool.test - Copyright (c) 2015 Sean Woods # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2 testsNeed TclOO 1 # use oodialect/oodialect.tcl oo::dialect support { use cron/cron.tcl cron use sha1/sha1.tcl sha1 } testing { useLocal tool.tcl tool } # ------------------------------------------------------------------------- |
︙ | ︙ | |||
100 101 102 103 104 105 106 | tool::class create OptionClass2 { superclass OptionClass property mass 1400kg option color {default: blue} } | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | tool::class create OptionClass2 { superclass OptionClass property mass 1400kg option color {default: blue} } OptionClass create ObjectOptionTest1 OptionClass create ObjectOptionTest2 bodystyle wagon transmission standard OptionClass2 create ObjectOptionTest3 OptionClass2 create ObjectOptionTest4 bodystyle SUV transmission cvt color white ### # Property ignores options ### |
︙ | ︙ | |||
412 413 414 415 416 417 418 | if {[string index $tkpath 0] eq "."} { set obj [my new $tkpath {*}[lrange $args 1 end]] $obj tkalias $tkpath return $tkpath } next {*}$args } | | | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | if {[string index $tkpath 0] eq "."} { set obj [my new $tkpath {*}[lrange $args 1 end]] $obj tkalias $tkpath return $tkpath } next {*}$args } constructor {TkPath args} { my variable hull set hull $TkPath my graft hull $TkPath } method tkalias tkname { set oldname $tkname my variable tkalias set tkalias $tkname set self [self] set hullwidget [::info object namespace $self]::tkwidget my graft tkwidget $hullwidget |
︙ | ︙ | |||
465 466 467 468 469 470 471 | my config set $args } } DummyClass create ::DbObj OrganClass create OrganObject db ::DbObj test tool-constructor-args-001 {Test that organs passed as options map correctly} { OrganObject organ db | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 | my config set $args } } DummyClass create ::DbObj OrganClass create OrganObject db ::DbObj test tool-constructor-args-001 {Test that organs passed as options map correctly} { OrganObject organ db } {::DbObj} test tool-constructor-args-002 {Test that organs passed as options map correctly} { OrganObject cget db } {::DbObj} tool::object create MorphOrganObject#1 tool::object create MorphOrganObject#2 MorphOrganObject#2 graft db ::DbObj |
︙ | ︙ | |||
575 576 577 578 579 580 581 | } {C} ### # Set of tests to exercise the mixinmap system ### tool::define MixinMainClass { variable mainvar unchanged | | | | | | | | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 | } {C} ### # Set of tests to exercise the mixinmap system ### tool::define MixinMainClass { variable mainvar unchanged method test::which {} { my variable mainvar return $mainvar } method test::main args { puts [list this is main $method $args] } } tool::define MixinTool { variable toolvar unchanged.mixin meta set mixin unmap-script: { my test untool $class } meta set mixin map-script: { my test tool $class } meta set mixin name: {Generic Tool} method test::untool class { my variable toolvar mainvar set mainvar {} set toolvar {} } method test::tool class { my variable toolvar mainvar set mainvar [$class meta get mixin name:] set toolvar [$class meta get mixin name:] } } tool::define MixinToolA { superclass MixinTool meta set mixin name: {Tool A} } |
︙ | ︙ | |||
653 654 655 656 657 658 659 | mixintest test which } {} ### # Coroutine tests ### tool::define coro_example { | | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 | mixintest test which } {} ### # Coroutine tests ### tool::define coro_example { dict_ensemble coro_a_info coro_a_info { initialize { restart 0 phase 0 loop 0 event 0 idle 0 } } coroutine coro_a { my coro_a_info merge { phase 0 loop 0 event 0 idle 0 } |
︙ | ︙ | |||
698 699 700 701 702 703 704 | b { my coro_b send [lrange $event 1 end] } } } } } | | | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 | b { my coro_b send [lrange $event 1 end] } } } } } dict_ensemble coro_b_info coro_b_info { initialize { restart 0 phase 0 loop 0 event 0 idle 0 } } coroutine coro_b { my coro_b_info merge { phase 0 loop 0 event 0 idle 0 } |
︙ | ︙ | |||
739 740 741 742 743 744 745 | a { my coro_a [lrange $event 1 end] } } } } } | | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 | a { my coro_a [lrange $event 1 end] } } } } } dict_ensemble coro_yodawg_info coro_yodawg_info { initialize { restart 0 phase 0 loop 0 event 0 idle 0 yodawg 0 } } coroutine coro_yodawg { my coro_yodawg_info merge { phase 0 loop 0 event 0 idle 0 yodawg 0 |
︙ | ︙ |
Changes to modules/tool/tool_dict_ensemble.man.
︙ | ︙ |
Changes to modules/treeql/treeql.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # treeql.test: tests for the tree query language # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # treeql.test: tests for the tree query language # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use snit/snit.tcl snit use struct/list.tcl struct::list # TODO: Add accel handling |
︙ | ︙ |
Changes to modules/uev/uevent.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { use log/logger.tcl logger } testing { useLocal uevent.tcl uevent |
︙ | ︙ |
Changes to modules/uri/uri-rfc2396.test.
1 2 3 4 5 6 7 | # -*- tcl -*- # ------------------------------------------------------------------------------ source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # -*- tcl -*- # ------------------------------------------------------------------------------ source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal uri.tcl uri } # ------------------------------------------------------------------------------ |
︙ | ︙ |
Changes to modules/uri/uri.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal uri.tcl uri } # ------------------------------------------------------------------------- |
︙ | ︙ |
Changes to modules/uri/urn.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # urn.test - Copyright (C) 2001 Pat Thoyts <[email protected]> # # Provide a set of tests to excercise the urn-scheme package. # # @(#)$Id: urn.test,v 1.9 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # urn.test - Copyright (C) 2001 Pat Thoyts <[email protected]> # # Provide a set of tests to excercise the urn-scheme package. # # @(#)$Id: urn.test,v 1.9 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useLocal uri.tcl uri } testing { useLocal urn-scheme.tcl uri::urn |
︙ | ︙ |
Changes to modules/virtchannel_base/pkgIndex.tcl.
︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 | package ifneeded tcl::chan::null 1 [list source [file join $dir null.tcl]] package ifneeded tcl::chan::nullzero 1 [list source [file join $dir nullzero.tcl]] package ifneeded tcl::chan::random 1 [list source [file join $dir random.tcl]] package ifneeded tcl::chan::std 1.0.1 [list source [file join $dir std.tcl]] package ifneeded tcl::chan::string 1.0.3 [list source [file join $dir string.tcl]] package ifneeded tcl::chan::textwindow 1 [list source [file join $dir textwindow.tcl]] package ifneeded tcl::chan::variable 1.0.4 [list source [file join $dir variable.tcl]] package ifneeded tcl::chan::zero 1 [list source [file join $dir zero.tcl]] package ifneeded tcl::randomseed 1 [list source [file join $dir randseed.tcl]] | > | 9 10 11 12 13 14 15 16 17 18 | package ifneeded tcl::chan::null 1 [list source [file join $dir null.tcl]] package ifneeded tcl::chan::nullzero 1 [list source [file join $dir nullzero.tcl]] package ifneeded tcl::chan::random 1 [list source [file join $dir random.tcl]] package ifneeded tcl::chan::std 1.0.1 [list source [file join $dir std.tcl]] package ifneeded tcl::chan::string 1.0.3 [list source [file join $dir string.tcl]] package ifneeded tcl::chan::textwindow 1 [list source [file join $dir textwindow.tcl]] package ifneeded tcl::chan::variable 1.0.4 [list source [file join $dir variable.tcl]] package ifneeded tcl::chan::wrapper 1 [list source [file join $dir wrapper.tcl]] package ifneeded tcl::chan::zero 1 [list source [file join $dir zero.tcl]] package ifneeded tcl::randomseed 1 [list source [file join $dir randseed.tcl]] |
Added modules/virtchannel_base/wrapper.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/env tclsh # # ## ### ##### ######## ############# # (C) 2018 Poor Yorick # # ## ### ##### ######## ############# package require Tcl 8.6 package require coroutine package require tcl::chan::events oo::class create ::tcl::chan::wrapper { superclass ::tcl::chan::events ; # -> initialize, finalize, watch constructor args { namespace path [list ::coroutine::util {*}[namespace path]] dict size $args foreach {key val} $args { switch $key { chan { set chan $chan } } } next {*}$args } method blocking {c m} { chan blocking $c $m } method cget {c o} { chan configure $chan $o } method cgetall c { chan configure $chan } method configure {c o v} { chan configure $chan $o $v } method finalize {} { close $chan next } method read {c n} { read $c $n } method seek {c o b} { seek $c $o $b } method write {c d} { puts -nonwline $chan $d } variable chan } package provide tcl::chan::wrapper 1 |
Changes to modules/virtchannel_core/transformcore.tcl.
︙ | ︙ | |||
49 50 51 52 53 54 55 | lappend supported $m } } return $supported } method finalize {c} { | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | lappend supported $m } } return $supported } method finalize {c} { set channel {} ; # Prevent destructor from calling close. my destroy return } # # ## ### ##### ######## ############# variable channel |
︙ | ︙ |
Changes to modules/virtchannel_transform/base64.tcl.
︙ | ︙ | |||
38 39 40 41 42 43 44 | return } oo::class create ::tcl::transform::base64::implementation { superclass tcl::transform::core ;# -> initialize, finalize, destructor method write {c data} { | | > > > > > > | > > > > > > > > | | | | > > > > < | | | 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 | return } oo::class create ::tcl::transform::base64::implementation { superclass tcl::transform::core ;# -> initialize, finalize, destructor method write {c data} { set res [my Code encodebuf encode $data 3] incr encdount [string length $data] return $res } method read {c data} { set length [string length $data] # remove whitespace to make framing calculations in [Code] accurate # to do: Add a -strict configuration to disallow whitespace? regsub -all {[[:space:]]} $data[set data {}] {} data set res [my Code decodebuf decode $data 4] incr deccount $length return $res } method flush {c} { set data [binary encode base64 $encodebuf] set encodebuf {} return $data } method drain {c} { set length [string length $decodebuf] set data [binary decode base64 $decodebuf] if {$data eq {} && $length} { error [list {invalid input after } $deccount] } set decodebuf {} return $data } method clear {c} { set decodebuf {} return } # # ## ### ##### ######## ############# constructor {} { set encodebuf {} set deccount 0 set enccount 0 set decodebuf {} return } # # ## ### ##### ######## ############# variable enccount encodebuf deccount decodebuf # # ## ### ##### ######## ############# method Code {bufvar op data n} { upvar 1 $bufvar buffer append buffer $data set n [my Complete $buffer $n] if {$n < 0} { return {} } set chunk [string range $buffer 0 $n] set result [binary $op base64 $chunk] if {$result eq {} && $chunk ne {}} { error [list {invalid input after} [ expr {$op eq {encode} ? $enccount : $deccount}]] } incr n set buffer [string range $buffer $n end] return $result } method Complete {buffer n} { set len [string length $buffer] return [expr {(($len / $n) * $n)-1}] } |
︙ | ︙ |
Changes to modules/virtchannel_transform/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded tcl::transform::adler32 1 [list source [file join $dir adler32.tcl]] package ifneeded tcl::transform::base64 1 [list source [file join $dir base64.tcl]] package ifneeded tcl::transform::counter 1 [list source [file join $dir counter.tcl]] package ifneeded tcl::transform::crc32 1 [list source [file join $dir crc32.tcl]] package ifneeded tcl::transform::hex 1 [list source [file join $dir hex.tcl]] package ifneeded tcl::transform::identity 1 [list source [file join $dir identity.tcl]] package ifneeded tcl::transform::limitsize 1 [list source [file join $dir limitsize.tcl]] package ifneeded tcl::transform::observe 1 [list source [file join $dir observe.tcl]] package ifneeded tcl::transform::otp 1 [list source [file join $dir otp.tcl]] package ifneeded tcl::transform::rot 1 [list source [file join $dir rot.tcl]] package ifneeded tcl::transform::spacer 1 [list source [file join $dir spacer.tcl]] package ifneeded tcl::transform::zlib 1.0.1 [list source [file join $dir zlib.tcl]] | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded tcl::transform::adler32 1 [list source [file join $dir adler32.tcl]] package ifneeded tcl::transform::base64 1 [list source [file join $dir base64.tcl]] package ifneeded tcl::transform::counter 1 [list source [file join $dir counter.tcl]] package ifneeded tcl::transform::crc32 1 [list source [file join $dir crc32.tcl]] package ifneeded tcl::transform::hex 1 [list source [file join $dir hex.tcl]] package ifneeded tcl::transform::identity 1 [list source [file join $dir identity.tcl]] package ifneeded tcl::transform::limitsize 1 [list source [file join $dir limitsize.tcl]] package ifneeded tcl::transform::observe 1 [list source [file join $dir observe.tcl]] package ifneeded tcl::transform::otp 1 [list source [file join $dir otp.tcl]] package ifneeded {tcl transform qp} 0.1 [list source [file join $dir qp.tcl]] package ifneeded tcl::transform::rot 1 [list source [file join $dir rot.tcl]] package ifneeded tcl::transform::spacer 1 [list source [file join $dir spacer.tcl]] package ifneeded tcl::transform::zlib 1.0.1 [list source [file join $dir zlib.tcl]] |
Added modules/virtchannel_transform/qp.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /usr/bin/env tclsh # # ## ### ##### ######## ############# # (C) 2018 Poor Yorick # # ## ### ##### ######## ############# package require {mime qp} package require tcl::transform::core namespace eval ::tcl::transform {} proc ::tcl::transform::qp chan { ::chan push $chan [qp::implementation new] return } oo::class create ::tcl::transform::qp::implementation { superclass tcl::transform::core ;# -> initialize, finalize, destructor method write {c data} { ::mime::qp::encode $data } method read {c data} { ::mime::qp::decode $data } } package provide {tcl transform qp} 0.1 |
Changes to modules/yaml/rb.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | puts [source yaml.tcl] } else { # all.tcl source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | puts [source yaml.tcl] } else { # all.tcl source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 if {$::tcl_version < 8.5} { if {[catch {package require dict}]} { puts " Aborting the tests found in \"[file tail [info script]]\"" puts " Requiring dict package, not found." return |
︙ | ︙ |
Changes to sak.tcl.
︙ | ︙ | |||
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | } # -------------------------------------------------------------- proc tclfiles {} { global distribution getpackage fileutil fileutil/fileutil.tcl set fl [fileutil::findByPattern $distribution -glob *.tcl] # Remove files under SCCS. They are repository, not sources to check. set tmp {} foreach f $fl { if {[string match *SCCS* $f]} continue lappend tmp $f } proc tclfiles {} [list return $tmp] return $tmp } proc modtclfiles {modules} { | > > > > > > > > > > | > > < | 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 | } # -------------------------------------------------------------- proc tclfiles {} { global distribution getpackage fileutil fileutil/fileutil.tcl foreach mod [modules] { build_amalgamation_mod $mod } set bl [fileutil::findByPattern $distribution -glob build.tcl] foreach f $bl { if {[file tail [file dirname $f]] ne "build"} continue puts "Invoke Build $f" exec [info nameofexecutable] $f } set fl [fileutil::findByPattern $distribution -glob *.tcl] # Remove files under SCCS. They are repository, not sources to check. set tmp {} foreach f $fl { if {[string match *SCCS* $f]} continue lappend tmp $f } proc tclfiles {} [list return $tmp] return $tmp } proc modtclfiles {modules} { global mfiles guide distribution load_modinfo set mfiles [list] foreach m $modules { build_amalgamation_mod $m eval $guide($m,pkg) $m __dummy__ } return $mfiles } proc modules {} { global distribution set fl [list] foreach f [glob -nocomplain [file join $distribution modules *]] { if {![file isdirectory $f]} {continue} build_amalgamation_mod [file tail $f] if {[string match CVS [file tail $f]]} {continue} if {![file exists [file join $f pkgIndex.tcl]]} {continue} lappend fl [file tail $f] } set fl [lsort $fl] proc modules {} [list return $fl] return $fl } |
︙ | ︙ | |||
163 164 165 166 167 168 169 | proc ipackages {args} { # Determine indexed packages (ifneeded, pkgIndex.tcl) global distribution if {[llength $args] == 0} {set args [modules]} | < > | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | proc ipackages {args} { # Determine indexed packages (ifneeded, pkgIndex.tcl) global distribution if {[llength $args] == 0} {set args [modules]} array set p {} foreach m $args { build_amalgamation_mod $m set f [open [file join $distribution modules $m pkgIndex.tcl] r] foreach line [split [read $f] \n] { if { [regexp {#} $line]} {continue} if {![regexp {ifneeded} $line]} {continue} regsub {^.*ifneeded } $line {} line regsub {([0-9]) \[.*$} $line {\1} line |
︙ | ︙ | |||
386 387 388 389 390 391 392 | array unset pf $n,* } set pp [array get p] unset p set ppcache($args) $pp | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 | array unset pf $n,* } set pp [array get p] unset p set ppcache($args) $pp return $pp } proc xNULL {args} {} proc xPackage {cmd args} { if {[string equal $cmd provide]} { global p pf currentfile foreach {n v} $args break |
︙ | ︙ | |||
719 720 721 722 723 724 725 | } proc getpdesc {} { global argv ; if {![checkmod]} return package require sak::doc sak::doc::Gen desc l $argv | | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 | } proc getpdesc {} { global argv ; if {![checkmod]} return package require sak::doc sak::doc::Gen desc l $argv array set _ {} foreach file [glob -nocomplain doc/desc/*.l] { set f [open $file r] foreach l [split [read $f] \n] { foreach {p sd d} $l break set _($p) [list $sd $d] } |
︙ | ︙ | |||
919 920 921 922 923 924 925 926 927 928 929 930 931 932 | validate_versions_cmp ip pp return } proc validate_testsuite_mod {m} { global distribution if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} { puts " Without testsuite : $m" } return } proc bench_mod {mlist paths interp flags norm format verbose output coll rep} { | > > > | 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 | validate_versions_cmp ip pp return } proc validate_testsuite_mod {m} { global distribution if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} { build_amalgamation_mod $m } if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} { puts " Without testsuite : $m" } return } proc bench_mod {mlist paths interp flags norm format verbose output coll rep} { |
︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 | } else { set output [open $output w] puts $output "# -*- tcl -*- bench/$format" puts $output $data close $output } } proc validate_testsuites {} { foreach m [modules] { validate_testsuite_mod $m } return } proc validate_pkgIndex_mod {m} { global distribution | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 | } else { set output [open $output w] puts $output "# -*- tcl -*- bench/$format" puts $output $data close $output } } proc build_amalgamation_mod {m} { global distribution amalgamation if {[info exists amalgamation($m)]} return if {![file exists [file join $distribution modules $m build build.tcl]]} { set amalgamation($m) 0 return 0 } set amalgamation($m) 1 getpackage fileutil fileutil/fileutil.tcl set modfile [file join $distribution modules $m $m.tcl] if {[file exists $modfile]} { set newest 0 foreach f [fileutil::findByPattern [file join $distribution modules $m build] -glob *.tcl] { set mtime [file mtime $f] if {$mtime>$newest} { set newest $mtime } } if {$newest<=[file mtime $modfile]} { return } } #puts [list REBUILDING MODULE $m] exec [info nameofexecutable] [file join $distribution modules $m build build.tcl] return 1 } proc validate_testsuites {} { foreach m [modules] { build_amalgamation_mod $m validate_testsuite_mod $m } return } proc validate_pkgIndex_mod {m} { global distribution |
︙ | ︙ | |||
1459 1460 1461 1462 1463 1464 1465 | if {[string equal \ docstrip/docstrip.tcl \ [file join [file tail [pwd]] $o]]} { # We are writing over code required by ourselves. # For easy recovery in case of problems we save | | | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 | if {[string equal \ docstrip/docstrip.tcl \ [file join [file tail [pwd]] $o]]} { # We are writing over code required by ourselves. # For easy recovery in case of problems we save # the original puts " *Saving original of code important to docstrip/regen itself*" write_out $o.bak [get_input $o] } write_out $o $outputs($o) } |
︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 | foreach f $critclmodules($pkg) { lappend files [file join $distribution modules $f] } } set target [file join $distribution modules] catch { puts "$critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files" | | | 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 | foreach f $critclmodules($pkg) { lappend files [file join $distribution modules $f] } } set target [file join $distribution modules] catch { puts "$critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files" eval exec $critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files } r puts $r return } # ------------------------------------------------------------------------- |
︙ | ︙ | |||
2016 2017 2018 2019 2020 2021 2022 | } return } proc _validate_all {} { global package_name package_version set i 0 | < | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 | } return } proc _validate_all {} { global package_name package_version set i 0 puts "Validating $package_name $package_version development" puts "===================================================" puts "[incr i]: Existence of testsuites ..." puts "------------------------------------------------------" validate_testsuites puts "------------------------------------------------------" puts "" |
︙ | ︙ | |||
2069 2070 2071 2072 2073 2074 2075 | if {$frink == {}} {puts " Tool 'frink' not found, no check"} if {($procheck == {}) || ($tclchecker == {})} { puts " Tools 'procheck'/'tclchecker' not found, no check" } if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} | | | > > > > > | | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 | if {$frink == {}} {puts " Tool 'frink' not found, no check"} if {($procheck == {}) || ($tclchecker == {})} { puts " Tools 'procheck'/'tclchecker' not found, no check" } if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) || ($nagelfar == {})} { puts "------------------------------------------------------" } if {($frink == {}) && ($procheck == {}) && ($tclchecker == {}) && ($nagelfar == {})} { return } if {$frink != {}} { run-frink puts "------------------------------------------------------" } if {$tclchecker != {}} { run-tclchecker puts "------------------------------------------------------" } elseif {$procheck != {}} { run-procheck puts "------------------------------------------------------" } if {$nagelfar !={}} { run-nagelfar puts "------------------------------------------------------" } puts "" return } proc _validate_module {m} { global package_name package_version set i 0 puts "Validating $package_name $package_version development -- $m" if {[build_amalgamation_mod $m]} { puts "===================================================" puts "Rebuilt module amalgamation" } puts "===================================================" puts "[incr i]: Existence of testsuites ..." puts "------------------------------------------------------" validate_testsuite_mod $m puts "------------------------------------------------------" puts "" |
︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 | puts "[incr i]: Static syntax check ..." puts "------------------------------------------------------" set frink [auto_execok frink] set procheck [auto_execok procheck] set nagelfar [auto_execok nagelfar] set tclchecker [auto_execok tclchecker] | | | | 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 | puts "[incr i]: Static syntax check ..." puts "------------------------------------------------------" set frink [auto_execok frink] set procheck [auto_execok procheck] set nagelfar [auto_execok nagelfar] set tclchecker [auto_execok tclchecker] if {$frink == {}} {puts " Tool 'frink' not found, no check"} if {($procheck == {}) || ($tclchecker == {})} { puts " Tools 'procheck'/'tclchecker' not found, no check" } if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) || ($nagelfar == {})} { puts "------------------------------------------------------" } if {($frink == {}) && ($procheck == {}) && ($nagelfar == {}) && ($tclchecker == {})} { return |
︙ | ︙ | |||
2253 2254 2255 2256 2257 2258 2259 | set email "<${sfuser}@users.sourceforge.net>" set pname [textutil::cap $package_name] set notice "[clock format [clock seconds] -format "%Y-%m-%d"] $name $email * * Released and tagged $pname $package_version ======================== | | | 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 | set email "<${sfuser}@users.sourceforge.net>" set pname [textutil::cap $package_name] set notice "[clock format [clock seconds] -format "%Y-%m-%d"] $name $email * * Released and tagged $pname $package_version ======================== * " set logs [list [file join $distribution ChangeLog]] foreach m [modules] { set m [file join $distribution modules $m ChangeLog] if {![file exists $m]} continue |
︙ | ︙ |
Changes to support/devel/sak/doc/kwic.txt.
︙ | ︙ |
Changes to support/devel/sak/doc/toc.txt.
︙ | ︙ | |||
413 414 415 416 417 418 419 | [item modules/bibtex/bibtex.man bibtex {Parse bibtex files}] [item modules/clock/iso8601.man clock_iso8601 {Parsing ISO 8601 dates/times}] [item modules/clock/rfc2822.man clock_rfc2822 {Parsing RFC 2822 dates/times}] [item modules/csv/csv.man csv {Procedures to handle CSV data.}] [item modules/htmlparse/htmlparse.man htmlparse {Procedures to parse HTML strings}] [item modules/inifile/ini.man inifile {Parsing of Windows INI files}] [item modules/markdown/markdown.man markdown {Converts Markdown text to HTML}] | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 | [item modules/bibtex/bibtex.man bibtex {Parse bibtex files}] [item modules/clock/iso8601.man clock_iso8601 {Parsing ISO 8601 dates/times}] [item modules/clock/rfc2822.man clock_rfc2822 {Parsing RFC 2822 dates/times}] [item modules/csv/csv.man csv {Procedures to handle CSV data.}] [item modules/htmlparse/htmlparse.man htmlparse {Procedures to parse HTML strings}] [item modules/inifile/ini.man inifile {Parsing of Windows INI files}] [item modules/markdown/markdown.man markdown {Converts Markdown text to HTML}] [item modules/mime/mime.man mime {Manipulation of Internet messages}] [item modules/rcs/rcs.man rcs {RCS low level utilities}] [item modules/string/token.man string::token {Regex based iterative lexing}] [item modules/string/token_shell.man string::token::shell {Parsing of shell command line}] [item modules/textutil/textutil.man textutil {Procedures to manipulate texts and strings.}] [item modules/textutil/adjust.man textutil::adjust {Procedures to adjust, indent, and undent paragraphs}] [item modules/textutil/patch.man textutil::patch {Application of uni-diff patches to directory trees}] [item modules/textutil/repeat.man textutil::repeat {Procedures to repeat strings.}] |
︙ | ︙ | |||
841 842 843 844 845 846 847 | [division_start md5] [item modules/md5/md5.man md5 {MD5 Message-Digest Algorithm}] [division_end] [division_start md5crypt] [item modules/md5crypt/md5crypt.man md5crypt {MD5-based password encryption}] [division_end] [division_start mime] | | | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 | [division_start md5] [item modules/md5/md5.man md5 {MD5 Message-Digest Algorithm}] [division_end] [division_start md5crypt] [item modules/md5crypt/md5crypt.man md5crypt {MD5-based password encryption}] [division_end] [division_start mime] [item modules/mime/mime.man mime {Manipulation of Internet messages}] [item modules/mime/smtp.man smtp {Client-side tcl implementation of the smtp protocol}] [division_end] [division_start multiplexer] [item modules/multiplexer/multiplexer.man multiplexer {One-to-many communication with sockets.}] [division_end] [division_start namespacex] [item modules/namespacex/namespacex.man namespacex {Namespace utility commands}] |
︙ | ︙ |
Changes to support/devel/sak/doc/toc_cats.txt.
︙ | ︙ | |||
413 414 415 416 417 418 419 | [item modules/bibtex/bibtex.man bibtex {Parse bibtex files}] [item modules/clock/iso8601.man clock_iso8601 {Parsing ISO 8601 dates/times}] [item modules/clock/rfc2822.man clock_rfc2822 {Parsing RFC 2822 dates/times}] [item modules/csv/csv.man csv {Procedures to handle CSV data.}] [item modules/htmlparse/htmlparse.man htmlparse {Procedures to parse HTML strings}] [item modules/inifile/ini.man inifile {Parsing of Windows INI files}] [item modules/markdown/markdown.man markdown {Converts Markdown text to HTML}] | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 | [item modules/bibtex/bibtex.man bibtex {Parse bibtex files}] [item modules/clock/iso8601.man clock_iso8601 {Parsing ISO 8601 dates/times}] [item modules/clock/rfc2822.man clock_rfc2822 {Parsing RFC 2822 dates/times}] [item modules/csv/csv.man csv {Procedures to handle CSV data.}] [item modules/htmlparse/htmlparse.man htmlparse {Procedures to parse HTML strings}] [item modules/inifile/ini.man inifile {Parsing of Windows INI files}] [item modules/markdown/markdown.man markdown {Converts Markdown text to HTML}] [item modules/mime/mime.man mime {Manipulation of Internet messages}] [item modules/rcs/rcs.man rcs {RCS low level utilities}] [item modules/string/token.man string::token {Regex based iterative lexing}] [item modules/string/token_shell.man string::token::shell {Parsing of shell command line}] [item modules/textutil/textutil.man textutil {Procedures to manipulate texts and strings.}] [item modules/textutil/adjust.man textutil::adjust {Procedures to adjust, indent, and undent paragraphs}] [item modules/textutil/patch.man textutil::patch {Application of uni-diff patches to directory trees}] [item modules/textutil/repeat.man textutil::repeat {Procedures to repeat strings.}] |
︙ | ︙ |
Changes to support/devel/sak/doc/toc_mods.txt.
︙ | ︙ | |||
336 337 338 339 340 341 342 | [division_start md5] [item modules/md5/md5.man md5 {MD5 Message-Digest Algorithm}] [division_end] [division_start md5crypt] [item modules/md5crypt/md5crypt.man md5crypt {MD5-based password encryption}] [division_end] [division_start mime] | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | [division_start md5] [item modules/md5/md5.man md5 {MD5 Message-Digest Algorithm}] [division_end] [division_start md5crypt] [item modules/md5crypt/md5crypt.man md5crypt {MD5-based password encryption}] [division_end] [division_start mime] [item modules/mime/mime.man mime {Manipulation of Internet messages}] [item modules/mime/smtp.man smtp {Client-side tcl implementation of the smtp protocol}] [division_end] [division_start multiplexer] [item modules/multiplexer/multiplexer.man multiplexer {One-to-many communication with sockets.}] [division_end] [division_start namespacex] [item modules/namespacex/namespacex.man namespacex {Namespace utility commands}] |
︙ | ︙ |
Changes to support/installation/actions.tcl.
︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 | xcopy $moddir [file join $libdir $module] 0 *.h return } proc _tcl {module libdir} { global distribution xcopy \ [file join $distribution modules $module] \ [file join $libdir $module] \ 0 *.tcl return } | > > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | xcopy $moddir [file join $libdir $module] 0 *.h return } proc _tcl {module libdir} { global distribution if {![file exists [file join $distribution modules $module $module.tcl]]} { if {[file exists [file join $distribution modules $module build build.tcl]]} { puts "REBUILDING MODULE $module" exec [info nameofexecutable] [file join $distribution modules $module build build.tcl] } } xcopy \ [file join $distribution modules $module] \ [file join $libdir $module] \ 0 *.tcl return } |
︙ | ︙ | |||
107 108 109 110 111 112 113 | [file join $distribution modules $module] \ [file join $libdir $module] \ 0 *.template return } proc _manfile {f format ext docdir} { return } | | > > > > > > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | [file join $distribution modules $module] \ [file join $libdir $module] \ 0 *.template return } proc _manfile {f format ext docdir} { return } proc _man {module format ext docdir} { if {[file exists [file join $distribution modules $module $module.main]]} return if {![file exists [file join $distribution modules $module build build.tcl]]} return puts "REBUILDING MODULE $module" exec [info nameofexecutable] [file join $distribution modules $module build build.tcl] return } proc _exa {module exadir} { global distribution xcopy \ [file join $distribution examples $module] \ [file join $exadir $module] \ 1 |
︙ | ︙ |
Changes to support/installation/modules.tcl.
︙ | ︙ | |||
51 52 53 54 55 56 57 | Module base64 _tcl _man _null Module bee _tcl _man _null Module bench _tcl _null _null Module bibtex _tcl _man _exa Module blowfish _tcl _man _null Module cache _tcl _man _null Module calendar _tci _man _null | > | > > | 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 | Module base64 _tcl _man _null Module bee _tcl _man _null Module bench _tcl _null _null Module bibtex _tcl _man _exa Module blowfish _tcl _man _null Module cache _tcl _man _null Module calendar _tci _man _null Module chan _tcl _man _null Module clay _tcl _man _null Module clock _tcl _man _null Module cmdline _tcl _man _null Module comm _tcl _man _null Module control _tci _man _null Module coroutine _tcl _null _null Module counter _tcl _man _null Module crc _tcl _man _null Module cron _tcl _man _null Module csv _tcl _man _exa Module debug _tcl _null _null Module defer _tcl _man _null Module des _tcl _man _null Module devtools _tcl _man _null Module dicttool _tcl _man _null Module dns _msg _man _exa Module docstrip _tcl _man _null Module doctools _doc _man _exa Module doctools2base _tcl _man _null Module doctools2idx _tcl _man _null Module doctools2toc _tcl _man _null Module dtplite _tcl _man _null Module ego _tcl _man _null Module exif _tcl _man _null Module fileutil _tcl _man _null Module ftp _tcl _man _exa Module ftpd _tcl _man _exa Module fumagic _tcl _man _null Module generator _tcl _man _null Module gpx _tcl _null _null |
︙ | ︙ |