-
Notifications
You must be signed in to change notification settings - Fork 97
/
sml.tcl
3494 lines (3317 loc) · 121 KB
/
sml.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
#! /usr/bin/tclsh
###############################################################################
# #
# File name sml #
# #
# Description Convert XML <-> SML, a Simple Markup Language. #
# #
# Notes XML is the standard for representing structured data. #
# But, XML has the drawback of being extremely verbose. #
# Contrary to what XML designers hoped, it is hard for #
# humans to manually edit anything but trivial XML files. #
# The goal of this program is to experiment with an #
# alternative representation for XML data, that is more #
# human-friendly (at least for C family programmers). #
# The goal is not to create an alternative to XML. SML is #
# XML. It's just a different presentaton of the same data. #
# Any valid XML file should be convertible into SML, and #
# back into XML, with no binary difference between the two. #
# A second goal is to minimize differences with XML. #
# #
# Principle: #
# XML elements: <tag attr="val" ...>content</tag> #
# SML elements: tag attr="val" ... {content} #
# #
# SML rules: #
# * Elements normally end at the end of the line. #
# * They continue on the next line if there's a trailing \. #
# * They also continue if there's an unmatched "quote" or #
# open {curly braces} block. #
# * ; separates multiple elements and text on the same line.#
# * The element contents are normally inside curly braces. #
# * The {braces} can be omitted if the whole content is #
# just one block of text. (ie. no markup, no CDATA.) #
# * Text data is normally within double quotes. #
# * The "quotes" can be omitted if the parentheses are #
# omitted, and the text does not contain blanks, #
# ", =, ;, #, {, }, <, >, nor a trailing \. #
# (ie. cannot be confused with an attribute or comment.) #
# * This is a #-- Comment -- . #
# * Simplified case for a # One-line comment. #
# * This is a <[[ CDATA section ]]> . #
# * A newline immediately following the <[[ is discarded. #
# #
# Note: Quotification rules are not the same for attributes #
# (Normal XML quotification: " forbidden inside string) #
# and quoted text (All " and \ are prepended with a \). #
# #
# Known problems with this script: #
# - The output contains line endings for the local OS. #
# This breaks binary compatibility with files coming from #
# another OS. But this does not break XML compatibility, #
# as the XML spec says all line endings become \n. #
# - SML does not support attributes without values. #
# Ex: <script async src="http://my/script.js"></script> #
# #
# Refer any problem or feedback to jf.larvoire@free.fr, #
# with [SML] in the email subject. #
# #
# Experimental ideas, implemented in the script: #
# - An {\n Indented CDATA section\n}. The CDATA is between #
# the two \n. The CDATA must be indented by 2 more spaces #
# then the previous line. The indentations are discarded: #
# Some PCDATA{ #
# The CDATA, indented w. 2 more spaces than prev line.#
# }More PCDATA. The } is aligned with the first line. #
# - Content blocks with a CDATA section spanning the whole: #
# tag ={ #
# Indented CDATA section with a trailing \n #
# } #
# tag =={ #
# Indented CDATA section without a trailing \n #
# } #
# tag =: One-line CDATA section with a trailing \n #
# tag ==: One-line CDATA section without a trailing \n #
# #
# Other possible changes: #
# - Simplify multiline quotification, ex <<EOF ... EOF ? #
# - Manage distinct encodings for the two sides? #
# - Manage a #! header line, to make executable sml scripts?#
# (For example for XSLT scripts) #
# - Store SML options in a dedicated XML comment? #
# - Store SML options in a dedicated ?sml processing instr? #
# #
# License Copyright (c) 2005-2014, Jean-François Larvoire #
# All rights reserved. #
# #
# Redistribution and use in source and binary forms, with #
# or without modification, are permitted provided that the #
# following conditions are met: #
# #
# * Redistributions of source code must retain the above #
# copyright notice, this list of conditions and the #
# following disclaimer. #
# * Redistributions in binary form must reproduce the above #
# copyright notice, this list of conditions and the #
# following disclaimer in the documentation and/or other #
# materials provided with the distribution. #
# #
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND #
# CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED #
# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED #
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A #
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE #
# COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,#
# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL#
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF #
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR #
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON #
# ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT #
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) #
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN #
# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #
# #
# Author Jean-François Larvoire, jf.larvoire@free.fr #
# #
# History #
# 2005-12-13 JFL Created this program as xml2sml. #
# 2006-08-28 JFL Redesigned completely. Preserve element alignment. #
# 2006-10-02 JFL Restructured to better match XML syntax and terminology. #
# Bug fix: Accept spaces around attributes = sign. #
# 2006-10-04 JFL Fixed several bugs. #
# Rewrote execution tracing using new Proc and Return procs.#
# 2007-05-16 JFL Added SML CDATA extensions = == =: ==: ={} =={} #
# 2008-09-08 JFL Updated proc IsXml to detect invalid but well-formed XML. #
# 2010-04-02 JFL Minor fix to the -V option: Exit after displaying it. #
# 2010-04-06 JFL Merged in my latest debugging framework. #
# Fixed a bug the made the program crash under Tcl 8.3. #
# 2010-04-18 JFL Fixed a bug in SML->XML conversion: Spaces after an #
# unquoted SML value were included in the XML value. #
# Unrelated, added a heuristic to better handle XML->SML #
# conversion of elements containing just spaces. #
# 2010-06-21 JFL Improved the heuristic for empty blocks encoding: #
# Use {} for multiline blocks, and "" for single-line ones. #
# 2011-08-17 JFL Added experimental support for extended tags names with #
# spaces, using the heuristic that a quoted SML string on #
# a new line is actually an element name. (Except for HTML) #
# Bugfix: Attribs. conversion failed on continuation lines. #
# 2013-07-23 JFL Merged in my latest debugging framework version. #
# 2013-09-21 JFL Added experimental {indented CDADA sections}. #
# 2013-09-22 JFL Added support for non-binary encodings. #
# 2013-09-23 JFL Added the -t option for self testing. #
# 2013-09-24 JFL Fixed a bug with empty elements followed by space or tab. #
# Added support for SGML definitions [subsections]. #
# 2013-09-25 JFL Removed several XDebug* calls, which improves perf a lot. #
# Bugfix: \xA0 is NOT an XML space. Use [ \t\r\n] in regxps.#
# Added BSD-style license in the header. #
# 2014-11-30 JFL Merged in my latest debugging framework version. #
# 2017-09-11 JFL Fixed bugs in SGML entities definitions conversion. #
# Fixed conversion of XML comments beginning with a #. #
# Fixed conversion of single 'quoted' attribute values. #
# Avoid exceptions when encountering unsupported encodings. #
# Improved the self-test to compare conversion results #
# both ways, and to optionally run recursively. #
# 2017-12-14 JFL Avoid a crash if the input contains less than 2 chars. #
# #
###############################################################################
set version "2017-12-14" ; # The version of this script
# Global variables
set inFile stdin ; # Input file handle. Default: stdin
set outFile stdout ; # Output file handle. Default: stdout
set inFileName "" ; # Input file name. "" = Not yet specified.
set outFileName "" ; # Output file name. "" = Not yet specified.
# List of HTML tags known to be often used without an end tag.
set endlessTags {
hr br img
}
###############################################################################
# Output, logging and debug library routines #
###############################################################################
#=============================================================================#
# Features: #
# - An output, logging and debug framework. #
# - An optional execution tracing framework. #
# - Use the best system logging functions available. #
# - Use Tcl's tracing capabilities, if available, else emulate them. #
# - In its own namespace to avoid name collisions. #
# - Extends standard Tcl commands (puts->Puts, exec->Exec, etc.) #
# #
# Usage: #
# source debuglib.tcl #
# debug::Import ; # Optional: Import public names from the ::debug namespace#
# #
# Categories of routines: #
# (See the section headers further down for details about each routine.) #
# - Namespace management routines: #
# Define a public proc: xproc #
# Define public variables: xvariable, xvars #
# Import all public procs and variables: Import #
# - General utility routines, used internally, and useful for more than debug:#
# Pop an argument off a variable arg list: PopArg, PeekArg, PopLast #
# Get a date/time stamp: Now, NowMS #
# Indent a (possibly multi-line) text string: IndentString #
# Get the name and value of a set of variables: VarsValue #
# Find a program in the PATH: Which #
# - Debug, output and logging routines: #
# Output strings to a choice of channel, private log, system log, callback. #
# Log strings: LogString (Private logs), LogSystem (System event log)... #
# Output and log strings: Puts, VerbosePuts, DebugPuts... #
# Output and log variables values: PutVars, DebugVars, DebugSVars.... #
# Indent the output of a command or a block of code: Indent #
# Check the verbosity mode: Quiet, Normal, Verbose, Debug, XDebug #
# Set the verbosity mode: SetQuiet, SetNormal, SetVerbose, SetDebug, ... #
# Set the debug output channel: SetDebugChannel, OpenNull #
# - Execution trace routines. #
# Trace a whole set of routines entry and exit: TraceProcs. Usage: #
# TraceProcs { # Begin proc tracing #
# # Put routines to trace here. No need to modify them. #
# } ; # End proc tracing. #
# Tracing goes to screen (if debug is on), and to the default log file. #
# This can be changed by inserting an optional filename argument. Ex: #
# TraceProcs /tmp/tmpfile.log { # Begin proc tracing ... } #
# Other routines used internally by TraceProcs: (Rarely needed anymore) #
# Get the current procedure name: ProcName. #
# Trace the entry in a routine with its parameters: TraceEntry #
# Trace the return value from a routine: Use Return instead of return. #
# Trace one routine entry and exit: Define it with Proc instead of proc. #
# - Miscelleanneous other routines. #
# A sample background error handler using this framework: bgerror #
# Generate an error, inclusing the call stack: Error #
# - Program Execution Management routines #
# Conditionally execute a program, w. logging and tracing options: Exec #
# Get the exit code of a program: ErrorCode #
# Conditionally execute a Tcl command: Do #
# Enable/Disable conditional execution: SetExec, SetNoExec #
# Test if we're in no-exec mode: NoExec #
# #
# See section comments in the code below for further details. #
#=============================================================================#
namespace eval ::debug {
#=============================================================================#
# Namespace management #
#=============================================================================#
# These namespace management routines can be defined in this, or the root namespace.
# They can be used to define public procs and variables in any namespace.
# If defined in the root namespace, these 2 directives are not necessary...
namespace export xproc ; # Make sure xproc itself is exported
variable xprocs xproc ; # List of public procs exported from this namespace
# Define a procedure to export from the namespace it's used in.
# This automatically defines an Import proc in the namespace it's used in.
proc xproc {name args body} {
set ns [uplevel 1 namespace current]
set Import ${ns}::Import
if {[lsearch [info procs $Import] $Import] == -1} { # Define Import once.
uplevel 1 namespace export Import
if {![info exists "${ns}::xvariables"]} {
set ${ns}::xvariables ""
}
# Import all this namespace routines into the caller's namespace.
proc $Import {} {
set ns [namespace current]
uplevel 1 [list namespace import -force "${ns}::*"]
# Duplicate Tcl execution trace operations, if any.
variable xprocs
catch { # This will fail in Tcl <= 8.3
foreach proc $xprocs {
foreach trace [trace info execution ${ns}::$proc] {
foreach {ops cmd} $trace break
uplevel 1 [list trace add execution $proc $ops $cmd]
}
}
}
# And import xvariables too
variable xvariables
foreach var $xvariables {
uplevel 1 [list upvar 0 ${ns}::$var $var]
}
}
}
uplevel 1 namespace export $name
proc ${ns}::$name $args $body
lappend ${ns}::xprocs $name ; # List of all procedures exported from this namespace.
}
# Define a variable to export from the namespace it's used in.
# Allow overriding it by defining it _before_ defining the namespace: set NS::VAR VALUE
xproc xvariable {name args} {
set ns [uplevel 1 namespace current]
if {![info exists "${ns}::$name"]} {
uplevel 1 variable [list $name] $args
}
if {![info exists "${ns}::xvariables"]} {
set ${ns}::xvariables ""
}
lappend ${ns}::xvariables $name ; # List of all variables exported from this namespace.
}
# Define multiple variables at once. Use [list name value] for initialized vars.
xproc xvars {args} {
foreach name $args {
uplevel 1 xvariable $name
}
}
#=============================================================================#
# General Purpose routines #
#=============================================================================#
# Remove an argument from the head of a routine argument list.
xproc PopArg {{name args}} {
upvar 1 $name args
set arg [lindex $args 0] ; # Extract the first list element.
set args [lrange $args 1 end] ; # Remove the first list element.
return $arg
}
# Remove an argument from the head of a routine argument list.
xproc PeekArg {{name args}} {
upvar 1 $name args
set arg [lindex $args 0] ; # Extract the first list element.
}
# Remove an argument from the head of a routine argument list.
xproc PopLast {{name args}} {
upvar 1 $name args
set arg [lindex $args end] ; # Extract the first list element.
set args [lreplace $args end end] ; # Remove the last list element.
return $arg
}
# Build a time stamp with the current time.
xproc Now {{sep " "}} { # For ISO 8601 strict compatibility, use sep "T".
clock format [clock seconds] -format "%Y-%m-%d$sep%H:%M:%S"
}
# Idem with milli-seconds.
# Warning: The Tcl doc states that [clock clicks -milliseconds] returns only a relative time.
# As far as I can tell, it does return 1000 times [clock seconds] on all machines I have access to,
# but some older Tcl versions use a 32-bits integer for the [clock clicks -milliseconds] result, which can wrap around.
if {[expr 1000000 * 1000000] == 1000000000000} { # 64-bits math
# puts "Defining 64-bits NowMS"
xproc NowMS {{sep " "}} { # For ISO 8601 strict compatibility, use sep "T".
set ms [clock clicks -milliseconds]
set s [expr $ms / 1000]
set ms [expr $ms % 1000]
format "%s.%03d" [clock format $s -format "%Y-%m-%d$sep%H:%M:%S"] $ms
}
} else { # 32-bits math
# puts "Defining 32-bits NowMS"
variable s0 [clock seconds]
variable ms0 [clock clicks -milliseconds]
variable s1 [clock seconds]
while {$s1 != $s0} { # Make sure there's no ambiguity on the $ms0 base second
set s0 $s1
set ms0 [clock clicks -milliseconds]
set s1 [clock seconds]
}
variable deltaS [expr ($ms0 / 1000) - $s0]
xproc NowMS {{sep " "}} { # For ISO 8601 strict compatibility, use sep "T".
variable deltaS
set ms [clock clicks -milliseconds]
set s [expr ($ms / 1000) - $deltaS]
set ms [expr $ms % 1000]
format "%s.%03d" [clock format $s -format "%Y-%m-%d$sep%H:%M:%S"] $ms
}
}
# Indent multiple lines
xproc IndentString {text {indent 2}} {
set spaces [string repeat " " $indent]
# regsub -all -line {^} $text $spaces text
# regsub "\n$spaces$" $text "\n" text ; # Do not indent after the final \n
regsub -all -line {^[^\r\n]} $text $spaces& text
return $text
}
# Mimimum of N numbers
xproc Min {min args} {
foreach arg $args {
if {$arg < $min} {
set min $arg
}
}
return $min
}
# Maximum of N numbers
xproc Max {max args} {
foreach arg $args {
if {$arg > $max} {
set max $arg
}
}
return $max
}
# Format array contents with one element (name value) per line
xproc FormatArray {a {maxDev 10}} {
upvar 1 $a a1
set string ""
set names [lsort -dictionary [uplevel 1 array names $a]]
# Find good column width for names.
set n 0 ; # Number of names
set maxLen 0 ; # Maximum length of a name
set total 0 ; # Total length of all names
foreach name $names {
incr n
set l [string length $name]
set maxLen [Max $l $maxLen]
incr total $l
}
if $n {
set average [expr $total / $n]
set limit [expr $average + $maxDev] ; # Reasonable limit to avoid oversize names
set width [Min $maxLen $limit] ; # Choose the smaller of the two.
# Output the data using that column width
foreach {name} $names {
# Note: If performance is critical, use [list] instead of [CondQuote] in this line:
append string [format "%-${width}s %s\n" [list $name] [CondQuote $a1($name)]]
}
}
return $string
}
# Find a program among optional absolute pathnames, else in the PATH.
# Arguments:
# prog File name to search in the PATH
# args Optional full pathnames (including file name) to search first
# Returns:
# The pathname of the first executable program found, or "" if none found.
# Windows + Unix generic version
switch $tcl_platform(platform) { # Platform-specific PATH delimiter
"windows" {
variable pathDelim ";"
variable pathExts {.com .exe .bat .cmd} ; # Default if not explicitely defined
}
"unix" - default {
variable pathDelim ":"
variable pathExts {} ; # Unix does not have implicit program extensions.
}
}
if [info exists ::env(PATHEXT)] { # Windows list of implicit program extensions
set pathExts [split $::env(PATHEXT) $pathDelim]
}
set pathExts [linsert $pathExts 0 ""] ; # In all cases, try the exact name first.
xproc Which {prog args} { # prog=Program Name; args=Optional absolute pathnames
variable pathDelim
variable pathExts
if [info exists ::env(PATH)] { # May not exist when started as a service.
set paths [split $::env(PATH) $pathDelim]
if {"$::tcl_platform(platform)" == "windows"} {
set paths [linsert $paths 0 ""] ; # Search in the current directory first
}
foreach path $paths {
lappend args [file join $path $prog]
}
}
foreach name $args {
foreach ext $pathExts {
if [file executable "$name$ext"] {
return "$name$ext"
}
}
}
return ""
}
# Escape a string. ie. change special string charaters to \c & \xNN sequences.
# Does the reverse of {subst -nocommands -novariables $text}
# 2014-11-14 JFL Rewrote Escape to run faster, scanning the whole string only once.
# Added support for Unicode characters > \xFF.
# Added support for unbalanced {curly braces}.
variable controlChar
array set controlChar {
0 {\x00} 1 {\x01} 2 {\x02} 3 {\x03} 4 {\x04} 5 {\x05} 6 {\x06} 7 {\a}
8 {\b} 9 {\t} 10 {\n} 11 {\v} 12 {\f} 13 {\r} 14 {\x0E} 15 {\x0F}
16 {\x10} 17 {\x11} 18 {\x12} 19 {\x13} 20 {\x14} 21 {\x15} 22 {\x16} 23 {\x17}
24 {\x18} 25 {\x19} 26 {\x1A} 27 {\x1B} 28 {\x1C} 29 {\x1D} 30 {\x1E} 31 {\x1F}
}
variable utf8isbuggy 0 ;# Some older Linux machines do not support \xA0-\xFF correctly
xproc Escape {text} {
variable controlChar
variable utf8isbuggy
set l [string length $text]
set result {}
set depth 0
set openBraces {}
# Convert every character in the input text
for {set i 0} {$i < $l} {incr i} {
set c [string index $text $i]
scan $c "%c" n
if {$n < 0x20} { # ASCII control character between 0x00 and \x1F
set c $controlChar($n)
} elseif {$n < 0x7F} { # ASCII printable character between 0x20 and \x7E
switch -- $c {
"\\" {set c "\\\\"}
"\[" {set c "\\\["}
"\]" {set c "\\\]"}
"\"" {set c "\\\""}
"\$" {set c "\\\$"}
"\{" {
incr depth
lappend openBraces [string length $result]
}
"\}" {
if {$depth > 0} {
incr depth -1
PopLast openBraces
} else {
set c "\\\}"
}
}
}
} elseif {$n < 0xA0} { # ASCII DEL + extended control characters between \x80 and \x9F
set c "\\x[format %02X $n]"
} elseif {$n < 0x100} { # 8-bits character between \xA0 and \xFF
if {$utf8isbuggy} { # Some older Linux machines do not support \xA0-\xFF correctly
set c "\\x[format %02X $n]"
}
} else { # 16-bits Unicode character > \xFF
set c "\\u[format %04X $n]"
}
append result $c
}
# Finally correct unbalanced braces, if any is left
while {$depth} { # There are unbalanced open parenthesis
set n [PopLast openBraces]
set result [string replace $result $n $n "\\\{"]
incr depth -1
}
return $result
}
# Quotify a string if needed. ie. when spaces, quotes, or a trailing \.
# Prefer {} for multi-line strings, and "" for single line strings.
xproc CondQuote {text} {
if {"$text" == ""} {
return {""}
}
# If there are brackets, quotes, backspaces, dollars, or newlines, but no invisible characters (including \r)
# Also exclude cases with \{, \}, or a trailing \, as these cannot be escaped properly in a curly brace block.
if {[regexp {[][""\\$\n]} $text -] && ![regexp {[\x00-\x09\x0B-\x1F\x7F-\x9F]|\\[{}]|\\$} $text -]} {
# Then enclose text in curly braces, to avoid escaping quotes, etc.
set result "\{" ;# The opening curly brace that will enclose the result
# Make sure that inner curly braces are balanced in result.
# Scan all text curly braces, and escape unbalanced closing braces.
set l [string length $text]
set depth 0
set openBraces {}
for {set i 0} {$i < $l} {incr i} {
set c [string index $text $i]
switch -- $c {
"\{" {
incr depth
lappend openBraces [string length $result]
}
"\}" {
if {$depth > 0} {
incr depth -1
PopLast openBraces
} else {
set c "\\\}"
}
}
}
append result $c
}
# Escape unbalanced opening braces, if any is left
while {$depth} { # There are unbalanced open parenthesis
set n [PopLast openBraces]
set result [string replace $result $n $n "\\\{"]
incr depth -1
}
append result "\}"
return $result
}
# Escape all special and invisible characters
set text [Escape $text]
if [regexp {\s} $text -] { # Surround with quotes if there are spaces.
set text "\"$text\""
}
return $text
}
#=============================================================================#
# Logging routines #
# #
# Several alternative logging options exists, which can be combined: #
# #
# LogEvent Calls both LogSystem and LogString. #
# LogSystem It logs into the system event log, using ONE method among #
# 1) SFS library routine hplsLog -> The cluster log #
# 2) evlsend -> The cluster log #
# 3) logger -> The local /var/log/messages log #
# LogString It logs into application-specific logs, using ALL methods:#
# LogToFile Log into a named log file. "" = none. #
# SetLogFile Define a default log file name. "" = none. #
# LogToCallBack Log into a user-defined callback. "" = none. #
# SetLogCallBack Define a log callback routine. "" = none. #
# LogToChannel Log into channel Ilo::hLogFile. "" = none. #
# OpenLogChannel Create a log file and store the handle into hLogFile. #
# CloseLogChannel Close Ilo::hLogFile, and clear the variable. #
#=============================================================================#
# Global settings. Can be overriden by defining them before referencing this pkg.
# Script name.
if [info exists ::argv0] { # argv0 is not always defined!
xvariable script [file tail $::argv0] ; # Use it if present.
} else {
xvariable script debuglib.tcl ; # Else use a clever default.
}
# Log file name. Deprecated mechanism. Use OpenLogChannel or open your own $hLogFile instead.
xvariable logFile "" ; # File name, or "" for none.
# Whether to create the above log file if absent.
xvariable createLog 0 ; # 0=Don't create; 1=Create it.
# Handle for a capture file opened by the user.
xvariable hLogFile "" ; # Tcl open channel, or "" for none.
variable hLogFileName ""
variable hLogFileDir ""
# Name of a user-defined callback logging routine, or "" for None.
xvariable logCallBack ""
# Name: "-"=stdout. Default path: ~/log/$script. Default name: timestamp.pid.log
xproc OpenLogChannel {{name ""}} {
variable hLogFile
variable hLogFileDir
variable hLogFileName
variable script
if {"$hLogFile" != ""} return ; # Already started
set nParts [llength [file split $name]]
set lastChar [string index $name end]
if {"$name" == "-"} { # Special case of logging to stdout
set hLogFileDir ""
} elseif {[file isdirectory $name] || ("$lastChar" == "/") || ("$lastChar" == "\\")} {
set hLogFileDir $name
set name ""
} elseif {$nParts > 1} {
set hLogFileDir [file dirname $name]
set name [file tail $name]
} elseif {"$name" != ""} { # A name was specified, thus relative to the current directory
set hLogFileDir ""
# All following alternatives are for the case where no name is specified
} elseif [file exists $hLogFileDir] { # Just reuse the previous directory
} elseif { ("$::tcl_platform(platform)" == "windows")
&& [file writable "$::env(windir)/logs"]} { # Windows Administrator user
set hLogFileDir "$::env(windir)/logs/[file rootname $script]"
} elseif [file writable /var/log] { # Unix root user
set hLogFileDir "/var/log/[file rootname $script]"
} else { # Non-root user
set hLogFileDir "$::env(HOME)/log/[file rootname $script]"
}
if {"$hLogFileDir" != ""} {
file mkdir $hLogFileDir ; # Create the log directory if needed.
}
if {"$name" == ""} {
set name "[clock format [clock seconds] -format "%Y%m%d_%H%M%S"].[pid].log"
}
set hLogFileName [file join $hLogFileDir $name]
if {"$hLogFileName" == "-"} {
set hLogFile stdout
puts "Logging to stdout."
# No need to log the command line, as it's a few lines above in the console output.
} else {
set exists [file exists $hLogFileName]
set hLogFile [open $hLogFileName a+] ; # And log everything into the given log file.
puts "Logging to file [CondQuote [file nativename $hLogFileName]]."
if {$exists} { # If the log file existed already, put a line delimiter
LogString [string repeat "-" 80]
}
LogString "$::argv0 $::argv"
LogString "# pid [pid]"
}
SetExpectLogFile ; # Send Expect logging there too. Ignores error if no Expect.
return $hLogFile
}
xproc CloseLogChannel {} {
variable hLogFile
if {"$hLogFile" != ""} {
close $hLogFile
set hLogFile ""
}
}
xproc SetExpectLogFile {} {
variable hLogFile
variable hLogFileName
catch { # This will fail when not running under expect. Ignore that.
log_file ; # Stop any previous expect logging
log_user 0 ; # Stop any previous expect logging
if {"$hLogFileName" == "-"} {
log_user 1
} elseif {"$hLogFile" != ""} {
log_file -leaveopen $hLogFile ; # And log everything into the given log file.
}
uplevel 1 InitTraceSend ; # And while we're at it, make sure send is traced too.
}
}
# Record a string in the system event log.
# Arguments:
# string String to record
# category server|storage|lustre|admin. Default: server
# severity debug|info|notice|warning|err|crit|alert|emerg. Default: info
# Notes:
# Standard Linux log facilities: (Same as category?)
# auth, authpriv, cron, daemon, ftp, kern, lpr, mail, news,
# syslog, user, uucp, and local0 to local7
# Returns:
# 0=Success; !0=Failure
xvariable evlsend [Which evlsend /sbin/evlsend] ; # An event log manager, working with evlview.
xvariable logger [Which logger /usr/bin/logger] ; # Another log file manager -> /var/log/messages
xproc LogSystem {string {severity info} {category user}} {
variable script
variable evlsend
variable logger
set tag $script
# Log it into the system event log, using one of several alternative methods.
if {"[info commands hplsLog]" == "hplsLog"} { # 1st choice: Use SFS' hplsLog.
set string "$tag: $string"
hplsLog $category $severity $string
} elseif {"$evlsend" != ""} { # 2nd choice: Use evlog's evlsend.
set string "$tag: $string"
# Note: Redirect stdin to /dev/null, as this may be executed with stdin closed.
catch [list exec $evlsend -f $category -t 1 -s $severity -m "$string" </dev/null]
} elseif {"$logger" != ""} { # 3rd choice: Use Linux logger.
# Contrary to others, logger accepts any tag instead of limited categories.
catch [list exec $logger -p syslog.$severity -t $tag "$string" </dev/null]
}
}
# Let the user define his own logging routine. For example use Expect send_log.
xproc LogToCallBack {string} {
variable logCallBack
if {"$logCallBack" != ""} {
$logCallBack $string
}
}
# Set the user-defined logging routine. Use "" to cancel.
xproc SetLogCallBack {callback} {
variable logCallBack
set logCallBack $callback
}
# Append a string to a private log file.
# Only output something if the file already exists.
# Open and close the file every time. This allows sharing it with other scripts.
# Arguments:
# string The string to log.
# fileName Log file name, or "" for $logFile, or "-" for stdout.
xproc LogToFile {string {fileName ""}} {
variable logFile
variable createLog
if {"$fileName" == ""} { # If not defined, use the default variable
set fileName $logFile
}
if {"$fileName" == ""} return ; # If still not defined, just return
if {("$fileName" == "-") || ($createLog || [file exists $fileName])} {
set header [format "[NowMS] %5d" [pid]]
catch { # exec echo "$header $string" >>$fileName
if {"$fileName" != "-"} {
set hf [open $fileName a+]
} else {
set hf stdout
}
puts $hf "$header $string"
if {"$fileName" != "-"} {
close $hf
}
}
}
}
# Log a string into all our private log alternatives.
# Arguments:
# -file NAME Opt. local log file name to use. Default: variable logFile.
# string The last argument = the string to output.
xproc LogString {args} {
variable logFile
variable hLogFile
set fileName $logFile
set log 0 ; # 1=Log the string into the system event log.
set string ""
while {"$args" != ""} {
set arg [PopArg]
switch -- $arg {
-f - -file { set fileName [PopArg] }
default { set string $arg ; break }
}
}
LogToFile $string $fileName ; # Log to the private log file, if any.
LogToCallBack $string ; # Log to the user-defined callback, if any.
if {"hLogFile" != ""} { # Log to the user-provided channel, if any.
# No need to log the pid here, as only one process can log at the same time.
catch {
puts $hLogFile "[NowMS] $string"
flush $hLogFile
}
}
}
# Routine for logging both to the system event log and to our private logs.
xproc LogEvent {string {severity info} {category server}} {
catch {LogString $string} ; # Log into our private logs; ignore I/O errors.
set err [LogSystem $string $severity $category] ; # Log into the system event log.
if $err {
DebugPuts "Error $err logging system event: \"$message\"" $severity $category
}
return $err
}
#=============================================================================#
# Debug output and logging #
# #
# Output procedures: #
# The core routine is Puts, which is a superset of puts. #
# Usage: XxxxPuts [options] [channel] string #
# #
# verbosity N Test proc Output proc Notes #
# -------- -- -------- ---------------- --------------------------------- #
# quiet 0 ForcePuts Quiet proc tests verbosity < 1 #
# normal 1 Normal Puts Everything logged in private logs #
# verbose 2 Verbose VerbosePuts #
# debug 3 Debug DebugPuts Indents output based on call depth#
# extra dbg 4 Xdebug XDebugPuts For extreme cases #
# #
# Variable redefinition procedures: #
# These routines output variable names and values, formated as valid tcl #
# command lines, allowing to reenter the variable in another tcl interpreter. #
# Ex: "set name value" or "array set name {key1 value1 key2 value2}" #
# VarsValue Generate a string with variables definitions #
# PutVars Display variables definitions #
# PutSVars Display a string, then variables definitions #
# DebugVars Display variables definitions, in debug mode only #
# DebugSVars Display a string, then variables definitions, in dbg mode only#
# #
# Debug ouput channel control: #
# The main debug output goes to channel $debugChannel. Default: stdout #
# SetDebugChannel Change it to stderr, or any other writable file handle. #
# OpenNull Open /dev/null or NUL, for use with SetDebugChannel. #
#=============================================================================#
# Global settings. Can be overriden by defining them before referencing this pkg.
# Output verbosity on stdout.
xvariable verbosity 1 ; # 0=Quiet 1=Normal 2=Verbose 3=Debug 4=XDebug
# Optional prefix to prepend to strings to output on stdout
# variable prefix "$script: "
xvariable prefix ""
# Optional indentation of the output
xvariable indent 0
# Optional ability to change the default debug output channel
xvariable debugChannel stdout
# Procedures checking if the current verbosity is at least at a given level.
foreach {name value} {Normal 1 Verbose 2 Debug 3 XDebug 4 XXDebug 5} {
xproc $name {} "
variable verbosity
expr \$verbosity >= $value
"
xproc Set$name {} "
variable verbosity
set verbosity $value
"
}
# Except for Quiet which checks it's at most that level
foreach {name value} {Quiet 0} {
xproc $name {} "
variable verbosity
expr \$verbosity <= $value
"
xproc Set$name {} "
variable verbosity
set verbosity $value
"
}
# Optional: Use a different channel for the debug output
xproc SetDebugChannel {channel} {
variable debugChannel
set debugChannel $channel
}
# Open the null file, possibly for disabling debug output
xproc OpenNull {} {
switch $::tcl_platform(platform) {
"windows" {
set null "NUL"
}
default {
set null "/dev/null"
}
}
open $null
}
# Increase/decrease the output indentation
xproc IncrIndent {{step 2}} { # Increase the indentation by one step.
variable indent
incr indent $step
}
xproc DecrIndent {{step 2}} { # Decrease the indentation by one step.
variable indent
incr indent -$step
}
xproc Indent {args} { # Run code, outputing at an increased indentation level.
IncrIndent
if {[llength $args] == 1} { # Block of code: Indent { code ; code ; ... }
set err [catch {uplevel 1 eval $args} result]
} else { # Inline command: Indent COMMAND ARG1 ARG2 ...
set err [catch {uplevel 1 $args} result]
}
DecrIndent
return -code $err $result
}
# Output a string and log it.
# Options:
# -1 Ignore 1 indent level. Ignored.
# -show [0|1] Whether to output on stdout. Default: 1=yes
# -file NAME Local log file name to use. Default: variable logFile.
# -log [0|1|SEV] Whether to log in the system event log. Default: 0=no
# -category CAT System event log category. Default: server
# -severity SEV System event log severity. Default: info
# -noprefix Do not prefix the application name before the output.
# -- End of Puts options.
# -nonewline Don't output a new line.
# Arguments:
# tclChannel Tcl file handle for output. Optional. Default: stdout
# string The last argument = the string to output.
variable atNewLine 1 ; # Record if the last output ended with a new line
xproc Puts {args} {
variable prefix
variable logFile
set show [Normal] ; # 1=Output the string on stdout, except in quiet mode.
set log 0 ; # 1=Log the string into the system event log.
set fileName $logFile ; # Local log file name
set category server
set severity info
variable indent
set doIndent $indent
while {"$args" != ""} {
set arg [PopArg]
switch -- $arg {
-1 { }
-category { set category [PopArg] }
-file { set fileName [PopArg] }
-i { set doIndent [PopArg] }
-log - -syslog { set log [PopArg] ; # Also allow severities here...
if [regexp {^[a-z]+$} $log severity] { set log 1 } }
-noprefix { set prefix "" }
-set { variable [PopArg] [PopArg] }
-severity { set severity [PopArg] }
-show { set show [PopArg] }
-- { break }
default { set args [linsert $args 0 $arg] ; break }
}
}
if {"$fileName" == "-"} { # "-" means log to standard output
set show 0 ; # Will be output by LogString
}
set msg [PopLast]
variable atNewLine
if {$doIndent && $atNewLine} {
set msg [IndentString $msg $doIndent]
}
LogString -file $fileName $msg ; # Always log the message in our private log.
if $show { # Output the message if requested
if {![catch {eof stdout}]} { # Avoid error if stdout is closed!
catch {eval puts $args [list "$prefix$msg"]}
}
}
set atNewLine [expr {([lsearch $args -nonewline] == -1)
|| ("[string index $msg end]" == "\n")
|| ($atNewLine && ("$msg" == ""))}] ; # Record if at EOL.
if $log { # Log it into the system event log if requested
LogSystem $msg $severity $category
}
}
# Output a string in all cases, even in Quiet mode.
# Arguments:
# args Arguments to pass to Puts.
xproc ForcePuts {args} {
eval Puts -show 1 $args
}
# Outputing a string in verbose or debug modes only.
# Arguments:
# options Options to pass to Puts. Default: None.
# string The last argument = the string to output.
xproc VerbosePuts {args} {
# Always call Puts: We want to log the string even if we don't display it.
eval Puts -show [Verbose] $args
}
# Allow extra indentation for routines run at caller's depth. (Using upelvel 1)
variable xdepth 0 ; # Extra depth level.
xproc DebugIndent {args} { # Run code, outputing at an increased indentation level.
variable xdepth