Tcl Library Source Code

Check-in [5d0a671a78]
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki

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

Overview
Comment:char - Reworked the internals to be more useful. Fixed the internals docs. Added testsuite. Version bumped to 1.0.1.
Timelines: family | ancestors | descendants | both | pt-work
Files: files | file ages | folders
SHA1: 5d0a671a7851bf9295038f035e917dde9f1f5218
User & Date: aku 2014-06-27 05:57:46
Context
2014-06-27
06:02
pt::rdengine (tcl) - Tweaks to the err msg code for clarity. check-in: 0d84367247 user: aku tags: pt-work
05:57
char - Reworked the internals to be more useful. Fixed the internals docs. Added testsuite. Version bumped to 1.0.1. check-in: 5d0a671a78 user: aku tags: pt-work
05:55
pt::pe - Added constructors for explicit char-classes and strings. Version bumped to 1.0.2. check-in: 10d94706b2 user: aku tags: pt-work
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/pt/char.tcl.

︙︙
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

	return [format %c 0x$hcode]

    }

    return $ch
}



proc ::char::quote::tcl {args} {
    if {1 == [llength $args]} { return [Tcl {*}$args] }
    set res {}
    foreach ch $args { lappend res [Tcl $ch] }
    return $res
}

proc ::char::quote::Tcl {ch} {
    # Converts a Tcl character (internal representation) into a string




    # which is accepted by the Tcl parser, will regenerate the
    # character in question and is 7bit ASCII.

    # Special characters

    switch -exact -- $ch {
	"\n" {return "\\n"}
	"\r" {return "\\r"}
	"\t" {return "\\t"}
	"\\" - "\;" -
	" "  - "\"" -
	"("  - ")"  -
	"\{" - "\}" -
	"\[" - "\]" {
	    # Quote space and all the brackets as well, using octal,
	    # for easy impure list-ness.

	    scan $ch %c chcode
	    return \\[format %o $chcode]
	}
    }

    scan $ch %c chcode

    # Control characters: Octal
    if {[::string is control -strict $ch]} {
	return \\[format %o $chcode]
    }

    # Beyond 7-bit ASCII: Unicode

    if {$chcode > 127} {
	return \\u[format %04x $chcode]
    }

    # Regular character: Is its own representation.

    return $ch
}



proc ::char::quote::string {args} {
    if {1 == [llength $args]} { return [String {*}$args] }
    set res {}
    foreach ch $args { lappend res [String $ch] }
    return $res
}

proc ::char::quote::String {ch} {
    # Converts a Tcl character (internal representation) into a string
    # which is accepted by the Tcl parser and will generate a human
    # readable representation of the character in question, one which
    # when written to a channel (via puts) describes the character
    # without using any unprintable characters. It may use backslash-
    # quoting. High utf characters are quoted to avoid problems with
    # the still prevalent ascii terminals. It is assumed that the
    # string will be used in a ""-quoted environment.

    # Special characters




    switch -exact -- $ch {
	" "  {return "<blank>"}
	"\n" {return "\\\\n"}
	"\r" {return "\\\\r"}
	"\t" {return "\\\\t"}
	"\"" - "\\" - "\;" -
	"("  - ")"  -
	"\{" - "\}" -
	"\[" - "\]" {
	    return \\$ch
	}
    }


    scan $ch %c chcode

    # Control characters: Octal
    if {[::string is control -strict $ch]} {
	return \\\\[format %o $chcode]
    }

    # Beyond 7-bit ASCII: Unicode

    if {$chcode > 127} {
	return \\\\u[format %04x $chcode]
    }

    # Regular character: Is its own representation.

    return $ch
}
















proc ::char::quote::cstring {args} {
    if {1 == [llength $args]} { return [CString {*}$args] }
    set res {}
    foreach ch $args { lappend res [CString $ch] }
    return $res
}

proc ::char::quote::CString {ch} {
    # Converts a Tcl character (internal representation) into a string
    # which is accepted by the Tcl parser and will generate a human
    # readable representation of the character in question, one which
    # when written to a channel (via puts) describes the character
    # without using any unprintable characters. It may use backslash-

    # quoting. High utf characters are quoted to avoid problems with
    # the still prevalent ascii terminals. It is assumed that the
    # string will be used in a ""-quoted environment.



    # Special characters

    switch -exact -- $ch {
	"\n" {return "\\\\n"}
	"\r" {return "\\\\r"}
	"\t" {return "\\\\t"}
	"\"" - "\\" {
	    return \\$ch
	}
    }

    scan $ch %c chcode

    # Control characters: Octal
    if {[::string is control -strict $ch]} {
	return \\\\[format %o $chcode]
    }

    # Beyond 7-bit ASCII: Unicode

    if {$chcode > 127} {






	return \\\\u[format %04x $chcode]
    }

    # Regular character: Is its own representation.

    return $ch
}



proc ::char::quote::comment {args} {
    if {1 == [llength $args]} { return [Comment {*}$args] }
    set res {}
    foreach ch $args { lappend res [Comment $ch] }
    return $res
}

proc ::char::quote::Comment {ch} {
    # Converts a Tcl character (internal representation) into a string
    # which is accepted by the Tcl parser when used within a Tcl








>
>
|
|
|





|
>
>
>
>
|
<

|
<



















|




<
|





<



>
>
|
|
|





|
|
|
|
|
|
|
|

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


|
<
<
|
<
<
<
|

<
<




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





|
<
|
<
<
>
|
<
|
>
>

|
<

|
|
|









|



<

>
>
>
>
>
>
|







>
>
|
|
|








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

	return [format %c 0x$hcode]

    }

    return $ch
}

# ### ### ### ######### ######### #########

proc ::char::quote::tcl {ch args} {
    if {![llength $args]} { return [Tcl $ch] }
    lappend res [Tcl $ch]
    foreach ch $args { lappend res [Tcl $ch] }
    return $res
}

proc ::char::quote::Tcl {ch} {
    # Input:  A single character
    # Output: A string representing the input.
    # Properties of the output:
    # (1) Contains only ASCII characters (7bit Unicode subset).
    # (2) When embedded in a ""-quoted Tcl string in a piece of Tcl
    #     code the Tcl parser will regenerate the input character.


    # Special character?

    switch -exact -- $ch {
	"\n" {return "\\n"}
	"\r" {return "\\r"}
	"\t" {return "\\t"}
	"\\" - "\;" -
	" "  - "\"" -
	"("  - ")"  -
	"\{" - "\}" -
	"\[" - "\]" {
	    # Quote space and all the brackets as well, using octal,
	    # for easy impure list-ness.

	    scan $ch %c chcode
	    return \\[format %o $chcode]
	}
    }

    scan $ch %c chcode

    # Control character?
    if {[::string is control -strict $ch]} {
	return \\[format %o $chcode]
    }


    # Unicode beyond 7bit ASCII?
    if {$chcode > 127} {
	return \\u[format %04x $chcode]
    }

    # Regular character: Is its own representation.

    return $ch
}

# ### ### ### ######### ######### #########

proc ::char::quote::string {ch args} {
    if {![llength $args]} { return [String $ch] }
    lappend res [String $ch]
    foreach ch $args { lappend res [String $ch] }
    return $res
}

proc ::char::quote::String {ch} {
    # Input:  A single character
    # Output: A string representing the input
    # Properties of the output
    # (1) Human-readable, for use in error messages, or comments.
    # (1a) Uses only printable characters.
    # (2) NO particular properties with regard to C or Tcl parsers.

    scan $ch %c chcode

    # Map the ascii control characters to proper names.
    if {($chcode <= 32) || ($chcode == 127)} {
	variable strmap
	return [dict get $strmap $chcode]
    }




    # Printable ascii characters represent themselves.



    if {$chcode < 128} {
	return $ch
    }

    # Unicode characters. Mostly represent themselves, except if
    # control or not printable. Then they are represented by their
    # codepoint.

    # Control characters: Octal
    if {[::string is control -strict $ch] ||


	![::string is print -strict $ch]} {



	return <U+[format %04x $chcode]>
    }



    return $ch
}

namespace eval ::char::quote {
    variable strmap {
	0 <NUL>  8 <BS>   16 <DLE> 24 <CAN>  32 <SPACE>
	1 <SOH>  9 <TAB>  17 <DC1> 25 <EM>  127 <DEL>
	2 <STX> 10 <LF>   18 <DC2> 26 <SUB>
	3 <ETX> 11 <VTAB> 19 <DC3> 27 <ESC>
	4 <EOT> 12 <FF>   20 <DC4> 28 <FS>
	5 <ENQ> 13 <CR>   21 <NAK> 29 <GS>
	6 <ACK> 14 <SO>   22 <SYN> 30 <RS>
	7 <BEL> 15 <SI>   23 <ETB> 31 <US>
    }
}

# ### ### ### ######### ######### #########

proc ::char::quote::cstring {ch args} {
    if {![llength $args]} { return [CString $ch] }
    lappend res [CString $ch]
    foreach ch $args { lappend res [CString $ch] }
    return $res
}

proc ::char::quote::CString {ch} {
    # Input:  A single character

    # Output: A string representing the input.


    # Properties of the output:
    # (1) Contains only ASCII characters (7bit Unicode subset).

    # (2) When embedded in a ""-quoted C string in a piece of
    #     C code the C parser will regenerate the input character
    #     in UTF-8 encoding.

    # Special characters (named).

    switch -exact -- $ch {
	"\n" {return "\\n"}
	"\r" {return "\\r"}
	"\t" {return "\\t"}
	"\"" - "\\" {
	    return \\$ch
	}
    }

    scan $ch %c chcode

    # Control characters: Octal
    if {[::string is control -strict $ch]} {
	return \\[format %o $chcode]
    }

    # Beyond 7-bit ASCII: Unicode

    if {$chcode > 127} {
	# Recode the character into the sequence of utf-8 bytes and
	# convert each to octal.
	foreach x [split [encoding convertto utf-8 $ch] {}] {
	    scan $x %c x
	    append res \\[format %o $x]
	}
	return $res
    }

    # Regular character: Is its own representation.

    return $ch
}

# ### ### ### ######### ######### #########

proc ::char::quote::comment {ch args} {
    if {![llength $args]} { return [Comment $ch] }
    lappend res [Comment $ch]
    foreach ch $args { lappend res [Comment $ch] }
    return $res
}

proc ::char::quote::Comment {ch} {
    # Converts a Tcl character (internal representation) into a string
    # which is accepted by the Tcl parser when used within a Tcl
︙︙
245
246
247
248
249
250
251
252
253


    return $ch
}

# ### ### ### ######### ######### #########
## Ready

package provide char 1









|
<

260
261
262
263
264
265
266
267



    return $ch
}

# ### ### ### ######### ######### #########
## Ready

package provide char 1.0.1

Added modules/pt/char.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

# -*- tcl -*-
# char.test:  tests for the char package.
#
# Copyright (c) 2014 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: char.test,v 1.1 2010/03/26 05:07:24 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 {
}
testing {
    useLocal char.tcl char
}

# -------------------------------------------------------------------------

set mytestdir tests/data

# -------------------------------------------------------------------------

source [localPath tests/char.tests]

#----------------------------------------------------------------------

unset mytestdir
testsuiteCleanup
return

Changes to modules/pt/pkgIndex.tcl. 

1
2
3
4
5
6
7
8
9
10
11

if {![package vsatisfies [package provide Tcl] 8.5]} return

# General utilities.
package ifneeded char          1 [list source [file join $dir char.tcl]]
package ifneeded configuration 1 [list source [file join $dir configuration.tcl]]
package ifneeded paths         1 [list source [file join $dir paths.tcl]]
package ifneeded text::write   1 [list source [file join $dir text_write.tcl]]

# AST support
package ifneeded pt::ast     1.1 [list source [file join $dir pt_astree.tcl]]





|








1
2
3
4
5
6
7
8
9
10
11

if {![package vsatisfies [package provide Tcl] 8.5]} return

# General utilities.
package ifneeded char          1.0.1 [list source [file join $dir char.tcl]]
package ifneeded configuration 1 [list source [file join $dir configuration.tcl]]
package ifneeded paths         1 [list source [file join $dir paths.tcl]]
package ifneeded text::write   1 [list source [file join $dir text_write.tcl]]

# AST support
package ifneeded pt::ast     1.1 [list source [file join $dir pt_astree.tcl]]
︙︙

Added modules/pt/tests/char.tests. 























































































































































































































































































































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

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

# -*- tcl -*-
# Testsuite for char.
# Called by the ../char.test driver file.

test char-1.0 {char, wrong#args} -body {
    char
} -returnCodes error \
    -result {wrong # args: should be "char subcommand ?argument ...?"}

test char-1.1 {char, bogus method} -body {
    char bogus
} -returnCodes error \
    -result {unknown or ambiguous subcommand "bogus": must be quote, or unquote}

test char-1.2 {char, wrong#args} -body {
    char quote
} -returnCodes error \
    -result {wrong # args: should be "char quote subcommand ?argument ...?"}

test char-1.3 {char, bogus method} -body {
    char quote bogus
} -returnCodes error \
    -result {unknown or ambiguous subcommand "bogus": must be comment, cstring, string, or tcl}

#----------------------------------------------------------------------

test char-2.0 {char tcl, wrong#args} -body {
    char quote tcl
} -returnCodes error -result {wrong # args: should be "char quote tcl ch ..."}

test char-2.1 {char tcl, single char} -body {
    char quote tcl A
} -result A

test char-2.2 {char tcl, multi char} -body {
    char quote tcl A B
} -result {A B}

foreach {n label input expected} {
    0 obrace    \{     \\173
    1 obrckt    \[     \\133
    2 dquote    \"     \\42
    3 escape    \033   \\33
    4 lf        \n     \\n
    5 space     { }    \\40
    6 backslash \\     \\134
    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\u229b
} {
    test char-2.3.$n "char tcl, map $label" -body {
	char quote tcl $input
    } -result $expected
}
unset -nocomplain n label input expected

#----------------------------------------------------------------------

test char-3.0 {char string, wrong#args} -body {
    char quote string
} -returnCodes error -result {wrong # args: should be "char quote string ch ..."}

test char-3.1 {char string, single char} -body {
    char quote string A
} -result A

test char-3.2 {char string, multi char} -body {
    char quote string A B
} -result {A B}

foreach {n label input expected} {
    0 obrace    \{     \{
    1 obrckt    \[     \[
    2 dquote    \"     \"
    3 escape    \033   <ESC>
    4 lf        \n     <LF>
    5 space     { }    <SPACE>
    6 backslash \\     \\
    7 A         A      A
    8 del       \177   <DEL>
    9 circast   \u229b \u229b
} {
    test char-3.3.$n "char string, map $label" -body {
	char quote string $input
    } -result $expected
}
unset -nocomplain n label input expected

#----------------------------------------------------------------------

test char-4.0 {char cstring, wrong#args} -body {
    char quote cstring
} -returnCodes error -result {wrong # args: should be "char quote cstring ch ..."}

test char-4.1 {char cstring, single char} -body {
    char quote cstring A
} -result A

test char-4.2 {char cstring, multi char} -body {
    char quote cstring A B
} -result {A B}

foreach {n label input expected} {
    0 obrace    \{     \{
    1 obrckt    \[     \[
    2 dquote    \"     \\\"
    3 escape    \033   \\33
    4 lf        \n     \\n
    5 space     { }    { }
    6 backslash \\     \\\\
    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\342\\212\\233
} {
    test char-4.3.$n "char cstring, map $label" -body {
	char quote cstring $input
    } -result $expected
}
unset -nocomplain n label input expected

#----------------------------------------------------------------------

test char-5.0 {char comment, wrong#args} -body {
    char quote comment
} -returnCodes error -result {wrong # args: should be "char quote comment ch ..."}

test char-5.1 {char comment, single char} -body {
    char quote comment A
} -result A

test char-5.2 {char comment, multi char} -body {
    char quote comment A B
} -result {A B}

foreach {n label input expected} {
    0 obrace    \{     \\\{
    1 obrckt    \[     \[
    2 dquote    \"     \\\"
    3 escape    \033   \\33
    4 lf        \n     \\n
    5 space     { }    <blank>
    6 backslash \\     \\
    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\u229b
} {
    test char-5.3.$n "char comment, map $label" -body {
	char quote comment $input
    } -result $expected
}
unset -nocomplain n label input expected

#----------------------------------------------------------------------
return

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