1# util-string.tcl --
2#
3#	This file implements package ::Utility::string, which  ...
4#
5# Copyright (c) 1997 Jeffrey Hobbs
6#
7# See the file "license.terms" for information on usage and
8# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9#
10#
11
12#package require NAME VERSION
13package provide ::Utility::string 1.0; # SET VERSION
14
15namespace eval ::Utility::string {;
16
17namespace export -clear *
18
19# string_cap --
20#
21#   Capitalize a string, or one char in it
22#
23# Arguments:
24#   str		input string
25#   idx		idx to capitalize
26# Results:
27#   Returns string with specified capitalization
28#
29proc string_cap {str {idx -1}} {
30    if {$i>-1} {
31	if {[string length $str]>$i} {
32	    return $str
33	} else {
34	}
35    } else {
36	return [string toupper [string index $str 0]][string tolower \
37		[string range $str 1 end]]
38    }
39}
40
41# string_reverse --
42#   reverses input string
43# Arguments:
44#   s		input string to reverse
45# Returns:
46#   string with chars reversed
47#
48;proc string_reverse s {
49    if {[set i [string len $s]]} {
50	while {$i} {append r [string index $s [incr i -1]]}
51	return $r
52    }
53}
54
55# obfuscate --
56#   If I describe it, it ruins it...
57# Arguments:
58#   s		input string
59# Returns:
60#   output
61#
62;proc obfuscate s {
63    if {[set len [string len $s]]} {
64	set i -1
65	while {[incr i]<$len} {
66	    set c [string index $s $i]
67	    if {[regexp "\[\]\\\[ \{\}\t\n\"\]" $c]} {
68		append r $c
69	    } else {
70		scan $c %c c
71		append r \\[format %0.3o $c]
72	    }
73	}
74	return $r
75    }
76}
77
78# untabify --
79#   removes tabs from a string, replacing with appropriate number of spaces
80# Arguments:
81#   str		input string
82#   tablen	tab length, defaults to 8
83# Returns:
84#   string sans tabs
85#
86;proc untabify {str {tablen 8}} {
87    set out {}
88    while {[set i [string first "\t" $str]] != -1} {
89	set j [expr {$tablen-($i%$tablen)}]
90	append out [string range $str 0 [incr i -1]][format %*s $j { }]
91	set str [string range $str [incr i 2] end]
92    }
93    return $out$str
94}
95
96# tabify --
97#   converts excess spaces to tab chars
98# Arguments:
99#   str		input string
100#   tablen	tab length, defaults to 8
101# Returns:
102#   string with tabs replacing excess space where appropriate
103#
104;proc tabify {str {tablen 8}} {
105    ## We must first untabify so that \t is not interpreted to be one char
106    set str [untabify $str]
107    set out {}
108    while {[set i [string first { } $str]] != -1} {
109	## Align i to the upper tablen boundary
110	set i [expr {$i+$tablen-($i%$tablen)-1}]
111	set s [string range $str 0 $i]
112	if {[string match {* } $s]} {
113	    append out [string trimright $s { }]\t
114	} else {
115	    append out $s
116	}
117	set str [string range $str [incr i] end]
118    }
119    return $out$str
120}
121
122# wrap_lines --
123#   wraps text to a specific max line length
124# Arguments:
125#   txt		input text
126#   len		desired max line length+1, defaults to 75
127#   P		paragraph boundary chars, defaults to \n\n
128#   P2		substitute for $P while processing, defaults to \254
129#		this char must not be in the input text
130# Returns:
131#   text with lines no longer than $len, except where a single word
132#   is longer than $len chars.  does not preserve paragraph boundaries.
133#
134;proc wrap_lines "txt {len 75} {P \n\n} {P2 \254}" {
135    regsub -all $P $txt $P2 txt
136    regsub -all "\n" $txt { } txt
137    incr len -1
138    set out {}
139    while {[string len $txt]>$len} {
140	set i [string last { } [string range $txt 0 $len]]
141	if {$i == -1 && [set i [string first { } $txt]] == -1} break
142	append out [string trim [string range $txt 0 [incr i -1]]]\n
143	set txt [string range $txt [incr i 2] end]
144    }
145    regsub -all $P2 $out$txt $P txt
146    return $txt
147}
148
149}; # end of namespace ::Utility::string
150