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