Artifact 59ff07e18af6c327ed6e8ce702e4877b92742b06:

• File packages/string/lib/printable.tcl — part of check-in [1aec0af314] at 2019-10-14 10:57:02 on branch trunk — string new routine regsub

  struct comment out debugging statement (user: pooryorick size: 2772)

#! /bin/env tclsh

variable doc::printable {
	description {
		Convert each backslash character and non-printing character in $string its \x or \u
		escaped form

		by default

			Tcl special characters are escaped
	}
	args {
		string {
			positional tail
			description {
				the string to convert 
			}
		}
		ascii {
			description {
				escape any character that is not an ascii printable character
			}
			default {lindex 1}
		}
		tcl {
			description {
				escape Tcl special characters
			}
			default {lindex 1}
		}
		tclescapes {
			description {
				use short Tcl escape sequences instead of hexadecimal escape
				sequences where possible
			}
			default {lindex 1}
		}
		tclsubs {
			default {lindex 0}
		}
		lineend {
			description {
				convert line ending characters
			}
			default {lindex 0}
		}
		other {
			description {
				other characters to escape
			}
			default {lindex {}}
		}
	}
	value {
		the converted string
	}
}
variable bchars {\a a \b b \f f \v v \n n \r r \t t \v v}
# tcl characters
variable tclchars {\n \r \{ \} $ \" [ ;  { }}
proc printable args {
package require {ycl proc}
[yclprefix] proc aliases {
	{ycl proc} {
		checkargs
	}
	{ycl string}
	{ycl var} {
		setmap
	}
	{ycl sugar} {
		block
	}
	{ycl var}
}
block {
	setmap {
		(
			@ascii@ $char ni $disallowed
			&& (
				[string is print $char]
				||
				$char in {\n \r}
			)
		)
	} {
		unicodecondition @ascii@ {}
		asciicondition @ascii@ {$char < "\x80" &&}
	}

	proc printable args [template asciicondition unicodecondition {

		variable bchars
		variable tclchars
		lappend disallowed "\\"
		checkargs $doc::printable {*}$args
		set res {}
		set slen [string length $string]


		set disallowed 

		if {$ascii} {
			set condition @asciicondition@
		} else {
			set condition @unicodecondition@
		}

		if {$tcl} {
			lappend disallowed {*}$tclchars 
		} else {
			if {$lineend} {
				lappend disallowed \r \n
			}
			if {$tclsubs} {
				lappend disallowed $ \[
			}
		}

		if {[llength $other]} {
			lappend disallowed {*}$other
		}



		set convert {
			if {$tclescapes && [dict exists $bchars $char]} {
				append res \\[dict get $bchars $char]
			} elseif {$tclescapes && $char in $tclchars} {
				append res \\$char
			} else {
				set ord [scan $char %c]
				if {$ord <= 0xff} { 
					set leader x
					set digits 2
				} elseif {$ord <= 0xffff} {
					set leader u
					set digits 4
				} elseif {$ord <= 0xffffffff}  {
					set leader U
					set digits 8
				} else {
					error [list {character is too large}]
				}
				append res "\\$leader[format %0${digits}x $ord]"
			}
		}
		for {set i 0} {$i<$slen} {::incr i} {
			set char [string index $string $i]
			if $condition {
				append res $char
			} else $convert
		}
		return $res
	}]
}
tailcall printable {*}$args
}