1# 2# arrayprocs.tcl -- 3# 4# Extended Tcl array procedures. 5# 6#------------------------------------------------------------------------------ 7# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. 8# 9# Permission to use, copy, modify, and distribute this software and its 10# documentation for any purpose and without fee is hereby granted, provided 11# that the above copyright notice appear in all copies. Karl Lehenbauer and 12# Mark Diekhans make no representations about the suitability of this 13# software for any purpose. It is provided "as is" without express or 14# implied warranty. 15#------------------------------------------------------------------------------ 16# $Id: arrayprocs.tcl,v 1.2 2002/04/02 03:00:14 hobbs Exp $ 17#------------------------------------------------------------------------------ 18# 19 20#@package: TclX-ArrayProcedures for_array_keys 21 22proc for_array_keys {varName arrayName codeFragment} { 23 upvar $varName enumVar $arrayName enumArray 24 25 if {![array exists enumArray]} { 26 return -code error "\"$arrayName\" isn't an array" 27 } 28 29 set code 0 30 set result {} 31 set searchId [array startsearch enumArray] 32 while {[array anymore enumArray $searchId]} { 33 set enumVar [array nextelement enumArray $searchId] 34 set code [catch {uplevel 1 $codeFragment} result] 35 if {$code != 0 && $code != 4} break 36 } 37 array donesearch enumArray $searchId 38 39 if {$code == 0 || $code == 3 || $code == 4} { 40 return $result 41 } 42 if {$code == 1} { 43 global errorCode errorInfo 44 return -code $code -errorcode $errorCode -errorinfo $errorInfo $result 45 } 46 return -code $code $result 47} 48