|
|
Posted by comp.lang.tcl on 04/21/06 18:52
Bryan Oakley wrote:
> comp.lang.tcl wrote:
> > Thanx for the proc, however, tclsh locks up tight, bringing down PHP
> > and Apache and all web services in the process, if you try this:
> >
> > set string [flatten [PROPER_CASE {{-hello} {world}}]]
> >
> > If you have a string with curly braces and a dash, it blows up. Take
> > one or the other away, all is well.
>
> "it blows up" does nothing to help us figure out the problem.
Sorry, there is no further description I can give you. tclsh locks,
produces 100% CPU usage when you view via top, no error logs of any
kind.
Here is PROPER_CASE:
[TCL]
#######################################################################################
#
# Proc PROPER_CASE - this proc will convert string text into "marquee"
style
# by displaying its "proper case" (or in this case: "Proper Case").
The
# first letter of each word is capitalized except for small words
(yet,
# small words are capitalized if they are the first word in the text).
# Special capitalization consideration is taken for common ethnic
words,
# hyphenated words, and words adjoined by underscores. Also
consideration is
# taken for words surrounded by non-alphabetic characters (updated
7/10/2000)
#
# UPDATE 11/21/00: Exemptions within the phrase are now accepted
within
# PROPER_CASE to allow for words within phrases to not be capitalized.
#
# SYNTAX: set myPhrase [PROPER_CASE $myPhrase] {for all words}
# set myPhrase [PROPER_CASE -exempt [list of exempted words]
-- $myPhrase]
#
# IMPORTANT: If you include a list of words to be exempted you MUST
include the
# following:
#
# -exempt : This flag indicates an exemption list is to
follow
# -- : End of exemption list
#
# Without including "-exempt" before your exemption list
there will be no
# words to exempt; without including "--" it cannot deduce
the end of the
# exemption list and this proc will return an empty string.
#
# Written by Phil Powell. All rights reserved. on 2/14/00, updated
7/10/00, 11/21/00
#
######################################################################################
proc PROPER_CASE {args} {
set lb [format %c 91]; set rb [format %c 93]; set bslash [format %c
92]
lappend statesList AL AK AR AZ CA CO CT DE DC FL GA HI ID IL IN IA KS
KY LA ME MD MA
lappend statesList MI MN MS MO MT NE NV NH NJ NM NY NC ND OH OK OR PA
RI SC SD TN TX
lappend statesList UT VT VA WA WV WI WY PR GU VI
lappend directionsList NE NW SE SW N.E. S.E. S.W. N.W.
set exemptFlag {}; set exemptHash {}; set phrase {}
if {[regexp -nocase -- "-exempt" [lindex $args 0]]} {
set exemptFlag [lindex $args 0]
set i 1
if {[lsearch -exact $args "--"] < 0} {set exemptFlag {}}
if {[string length $exemptFlag] > 0} {
while {![regexp -- "--" [lindex $args $i]]} {
lappend exemptList "[lindex $args $i]"
incr i
}
set exemptHash [lindex $args $i]
set phrase [lindex $args [expr {$i + 1}]]
}
} else {
set phrase [lindex $args 0]
}
regsub -all {"} $phrase "%1%" phrase
regsub -all "$bslash[set lb](.*)$bslash$rb" $phrase "%2%[set
bslash]1%2%" phrase
lappend smallWords a an in of
lappend exemptionVars statesList directionsList
if {[string length $exemptFlag] > 0 && [string length $exemptHash] > 0
&& [info exists exemptList]} {
lappend exemptionVars exemptList
}
for {set i 0} {$i < [llength $phrase]} {incr i} {
set word [lindex $phrase $i]
set isExempted 0
foreach smallWord $smallWords {
if {$smallWord == $word && $i > 0} { set isExempted 1 }
}
if {$word == [string toupper $word] && !$isExempted} {set isExempted
1}
if {!$isExempted} {
foreach exemptionVar $exemptionVars {
if {[lsearch -exact [set $exemptionVar] "$word"] >=0} {set
isExempted 1}
}
}
if {!$isExempted} {
foreach char "- _" {
set foundChar 0
if {[regexp -- "$char" $word]} {
set word [split $word "$char"]
set foundChar 1
}
for {set j 0} {$j < [llength $word]} {incr j} {
set wordlet [lindex $word $j]
set beginIndx 0; set nonWord {}
while {![regexp -nocase {[a-z]} [string index $wordlet $beginIndx]]}
{
append nonWord [string index $wordlet $beginIndx]
incr beginIndx
}
### Check to see if word is "Scots/Irish" but > 2 chars
set tinyWord 0; set letter {}
if {[expr [string length $wordlet] - [string length $nonWord]] <
3} {
### Avoid setting of string range > 1 if word < 2 chars
set tinyWord 1
set endIndx [expr [string length $wordlet] - 1]
} else {
set endIndx [expr [string length $nonWord] + 1]
}
set snippet [string tolower [string range $wordlet $beginIndx
$endIndx]]
if {!$tinyWord} {
set letter [string index $wordlet [expr 2 + [string length
$nonWord]]]
if {($snippet == "mc" || $snippet == "o'")} {
set letter [string toupper $letter]
}
}
set tempsnippet "$nonWord[string toupper [string index $snippet
0]]"
if {$endIndx > 0} {
append tempsnippet [string index $snippet 1]
}
set snippet $tempsnippet
set tempwordlet $snippet$letter
if {!$tinyWord} {
append tempwordlet [string range $wordlet [expr 3 + [string
length $nonWord]] end]
}
set wordlet $tempwordlet
set word [lreplace $word $j $j $wordlet]
}; # end of "j" for loop
if {$foundChar} {
set word [join $word "$char"]
}
}; # End of foreach
set phrase [lreplace $phrase $i $i $word]
}; # end of "if {!$isExempted}"
}; # end of outer for loop
regsub -all "%1%" $phrase {"} phrase
regsub -all "%2%(.*)%2%" $phrase "$lb[set bslash]1$rb" phrase
return $phrase
}
[/TCL]
Do you get
> any sort of tcl error you can show us, either on the web page or in a
> log? It really sounds like your problem is that PROPER_CASE is buggy,
> and/or it is improperly documented.
>
> Would it be possible for you to show us the result of the following command?
>
> [list PROPER_CASE [info args PROPER_CASE] [info body PROPER_CASE]]
>
>
>
>
> --
> Bryan Oakley
> http://www.tclscripting.com
[Back to original message]
|