TCL script to print range of lines and create the variables - tcl

Hi I am having a code as stated below
module abcd( a , b , c ,da , fa, na , ta , ma , ra ,
ta, la , pa );
input a , b, da ,fa , na , ta , ma;
output c , ra ,ta ,
la ,pa ;
wire a , b , da , fa ,na ,
ta , ma;
// MBIST Structures
mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;
mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;
// HMS
kkkks ;
jsskks;
endmodule
Need to take the range between "MBIST Structures " and "//" and the take the first line as a input variable and second line as a output variable.
For example , I am trying below stated code
proc findrange {data start {stop ;}} {
# Find the starting pattern
set x1 [string first $start $data]
if {$x1 < 0} {
# Pattern not found
return
}
# Skip the pattern
incr x1 [string length $start]
# Find the ending pattern after the starting position
set x2 [string first $stop $data $x1]
if {$x2 < 0} {
# Return the remainder of the data when no ending pattern is found
return [string range $data $x1 end]
} else {
# Return the text between the starting and ending patterns
return [string range $data $x1 [expr {$x2 - 1}]]
}
}
set chan [open "mode.v"]
set code [read $chan]
close $chan
set var4 [ findrange $code "MBIST Structures" \/\/]
echo $var4 is printing these variables
mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;
mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;
I want to have two lists
$input should be "mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;"
$output should be "mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;"
How to create these variables from the var4 variable
When I am trying out to print out the $var4 variable , it is printing 4 independent variables
foreach p $var4 {
echo $p
}
mbist_hsm_p::mbist_out_hsm_t
mbist_out_hsm;
mbist_hsm_p::mbist_in_hsm_t
mbist_in_hsm;
Rather it should be " mbist_hsm_p::mbist_out_hsm_t mbist_out_hsm;"
and other one should be "mbist_hsm_p::mbist_in_hsm_t mbist_in_hsm;"
Two lists I am looking for
$input and $output

With a short input file like this, it is much easier to read the whole file into a variable. And for the described task I think string first is a better choice than string match.
So this is how I would do it:
proc findrange {data start {stop ;}} {
# Find the starting pattern
set x1 [string first $start $data]
if {$x1 < 0} {
# Pattern not found
return
}
# Skip the pattern
incr x1 [string length $start]
# Find the ending pattern after the starting position
set x2 [string first $stop $data $x1]
if {$x2 < 0} {
# Return the remainder of the data when no ending pattern is found
return [string range $data $x1 end]
} else {
# Return the text between the starting and ending patterns
return [string range $data $x1 [expr {$x2 - 1}]]
}
}
set chan [open "mod1.v"]
set code [read $chan]
close $chan
set out [open "output.file.txt" "w"]
puts $out [findrange $code input]
puts $out [findrange $code output]
close $out
There is some change in the white space between your input and the desired
output you specified. But you didn't indicate the rules for that transformation and they are not obvious. So, I am ignoring that for the moment.

Related

Replace same strings with swap difference?

To manipulate Strings in Tcl, we use the string command.
If you need to replace comma:
set value { 10.00 }
puts [string map -nocase { . , } $value]
# Return: 10,00
We can replace several strings:
set text "This is a replacement test text"
puts [string map -nocase { e E s S a A } $text]
# Returns: THIS IS A TEXT OF REPLACEMENT TEST
Of course, we can replace words:
set text "This is a replacement test text"
puts [string map -nocase {test TEST a {second}} $text]
# Returns: This is the second replacement TEST text.
So far so good!
But one question that does not want to be silent is .. How to replace more than one identical occurrence in the sentence, giving a DIFFERENT substitution for each of them?
For example:
set time {10:02:12}
puts [string map -nocase { { : +} {: =} } $time]
I would like this result: 10 + 02 = 12
proc seqmap {str match args} {
set rc $str
foreach l [lreverse [regexp -all -indices -inline ***=$match $str]] \
replacement [lreverse $args] {
set rc [string replace $rc {*}$l $replacement]
}
return $rc
}
seqmap 10:02:12 : { + } { = }
=> 10 + 02 = 12
I'm using lreverse in case the replacement has a different length than the string it replaces. The indices would be off if the replacements were done from left to right.
The ***= is used to avoid special treatment of wildcard characters in the match string.
Of course, things get a lot more complicated if you want to handle the case where the number of occurrences doesn't match the number of provided substitutions. And even more if you want to replace several different strings.
This version handles the complications mentioned above:
proc seqmap {map str} {
# Transform the map into a dict with each key containing a list of replacements
set mapdict {}
foreach {s r} $map {dict lappend mapdict $s $r}
# Build a map where each key maps to a unique tag
# At the same time build a dict that maps our tags to the replacements
# First map the chosen tag character in case it is present in the string
set newmap {# #00}
set mapdict [dict map {s r} $mapdict {
lappend newmap $s [set s [format #%02d [incr num]]]
set r
}]
# Add the tag character to the dict so it can be mapped back
dict set mapdict #00 #
# Map the tags into the string
set rc [string map $newmap $str]
# Locate the positions where the tags ended up
set match [regexp -all -indices -inline {#\d\d} $rc]
# Create a list of replacements matching the tags
set replace [lmap l $match {
# Extract the tag
set t [string range $rc {*}$l]
# Obtain a replacement for this tag
set s [lassign [dict get $mapdict $t] r]
# Return the used replacement to the end of the list
dict set mapdict $t [linsert $s end $r]
# Add the replacement to the list
set r
}]
# Walk the two lists in reverse order, replacing the tags with the selected replacements
foreach l [lreverse $match] r [lreverse $replace] {
set rc [string replace $rc {*}$l $r]
}
# Done
return $rc
}
You call it just like you would string map, so with a key-value mapping and the string to perform the replacements on. Any duplicated keys specify the subsequent values to be substituted for each occurrence of the key. When the list is exhausted it starts over from the beginning.
So puts [seqmap {: + : = : *} 10:02:12] => 10+02=12
And puts [seqmap {: + : =} 10:02:12:04:16] => 10+02=12+04=16
As presented, the command can handle up to 99 unique keys. But it can easily be updated if more are needed.

how to split a file to list of lists TCL

I'm coding TCL and I would like to split a file into two lists of lists,
the file contain:
(1,2) (3,4) (5,6)
(7,8) (9,10) (11,12)
and I would like to get two list
one for each line, that contain lists that each one contain to two number
for example:
puts $list1 #-> {1 2} {3 4} {5 6}
puts [lindex $list1 0] #-> 1 2
puts [lindex $list2 2] #-> 11 12
I tried to use regexp and split but no success
The idea of using regexp is good, but you'll need to do some post-processing on its output.
# This is what you'd read from a file
set inputdata "(1,2) (3,4) (5,6)\n(7,8) (9,10) (11,12)\n"
foreach line [split $inputdata "\n"] {
# Skip empty lines.
# (I often put a comment format in my data files too; this is where I'd handle it.)
if {$line eq ""} continue
# Parse the line.
set bits [regexp -all -inline {\(\s*(\d+)\s*,\s*(\d+)\s*\)} $line]
# Example results of regexp:
# (1,2) 1 2 (3,4) 3 4 (5,6) 5 6
# Post-process to build the lists you really want
set list([incr idx]) [lmap {- a b} $bits {list $a $b}]
}
Note that this is building up an array; long experience says that calling variables list1, list2, …, when you're building them in a loop is a bad idea, and that an array should be used, effectively giving variables like list(1), list(2), …, as that yields a much lower bug rate.
An alternate approach is to use a simpler regexp and then have scan parse the results. This can be more effective when the numbers aren't just digit strings.
foreach line [split $inputdata "\n"] {
if {$line eq ""} continue
set bits [regexp -all -inline {\([^()]+\)} $line]
set list([incr idx]) [lmap substr $bits {scan $substr "(%d,%d)"}]
}
If you're not using Tcl 8.6, you won't have lmap yet. In that case you'd do something like this instead:
foreach line [split $inputdata "\n"] {
if {$line eq ""} continue
set bits [regexp -all -inline {\(\s*(\d+)\s*,\s*(\d+)\s*\)} $line]
set list([incr idx]) {}
foreach {- a b} $bits {
lappend list($idx) [list $a b]
}
}
foreach line [split $inputdata "\n"] {
if {$line eq ""} continue
set bits [regexp -all -inline {\([^()]+\)} $line]
set list([incr idx]) {}
foreach substr $bits {
lappend list($idx) [scan $substr "(%d,%d)"]
# In *very* old Tcl you'd need this:
# scan $substr "(%d,%d)" a b
# lappend list($idx) [list $a $b]
}
}
You have an answer already, but it can actually be done a little bit simpler (or at least without regexp, which is usually a good thing).
Like Donal, I'll assume this to be the text read from a file:
set lines "(1,2) (3,4) (5,6)\n(7,8) (9,10) (11,12)\n"
Clean it up a bit, removing the parentheses and any white space before and after the data:
% set lines [string map {( {} ) {}} [string trim $lines]]
1,2 3,4 5,6
7,8 9,10 11,12
One way to do it with good old-fashioned Tcl, resulting in a cluster of variables named lineN, where N is an integer 1, 2, 3...:
set idx 0
foreach lin [split $lines \n] {
set res {}
foreach li [split $lin] {
lappend res [split $li ,]
}
set line[incr idx] $res
}
A doubly iterative structure like this (a number of lines, each having a number of pairs of numbers separated by a single comma) is easy to process using one foreach within the other. The variable res is used for storing result lines as they are assembled. At the innermost level, the pairs are split and list-appended to the result. For each completed line, a variable is created to store the result: its name consists of the string "line" and an increasing index.
As Donal says, it's not a good idea to use clusters of variables. It's much better to collect them into an array (same code, except for how the result variable is named):
set idx 0
foreach lin [split $lines \n] {
set res {}
foreach li [split $lin] {
lappend res [split $li ,]
}
set line([incr idx]) $res
}
If you have the results in an array, you can use the parray utility command to list them in one fell swoop:
% parray line
line(1) = {1 2} {3 4} {5 6}
line(2) = {7 8} {9 10} {11 12}
(Note that this is printed output, not a function return value.)
You can get whole lines from this result:
% set line(1)
{1 2} {3 4} {5 6}
Or you can access pairs:
% lindex $line(1) 0
1 2
% lindex $line(2) 2
11 12
If you have the lmap command (or the replacement linked to below), you can simplify the solution somewhat (you don't need the res variable):
set idx 0
foreach lin [split $lines \n] {
set line([incr idx]) [lmap li [split $lin] {
split $li ,
}]
}
Still simpler is to let the result be a nested list:
set lineList [lmap lin [split $lines \n] {
lmap li [split $lin] {
split $li ,
}
}]
You can access parts of the result similar to above:
% lindex $lineList 0
{1 2} {3 4} {5 6}
% lindex $lineList 0 0
1 2
% lindex $lineList 1 2
11 12
Documentation:
array,
foreach,
incr,
lappend,
lindex,
lmap (for Tcl 8.5),
lmap,
parray,
set,
split,
string
The code works for windows :
TCL file code is :
proc captureImage {} {
#open the image config file.
set configFile [open "C:/main/image_config.txt" r]
#To retrive the values from the config file.
while {![eof $configFile]} {
set part [split [gets $configFile] "="]
set props([string trimright [lindex $part 0]]) [string trimleft [lindex $part 1]]
}
close $configFile
set time [clock format [clock seconds] -format %Y%m%d_%H%M%S]
set date [clock format [clock seconds] -format %Y%m%d]
#create the folder with the current date
set folderPath $props(folderPath)
append folderDate $folderPath "" $date "/"
set FolderCreation [file mkdir $folderDate]
while {0} {
if { [file exists $date] == 1} {
}
break
}
#camera selection to capture image.
set camera "video"
append cctv $camera "=" $props(cctv)
#set the image resolution (XxY).
set resolutionX $props(resolutionX)
set resolutionY $props(resolutionY)
append resolution $resolutionX "x" $resolutionY
#set the name to the save image
set imagePrefix $props(imagePrefix)
set imageFormat $props(imageFormat)
append filename $folderDate "" $imagePrefix "_" $time "." $imageFormat
set logPrefix "Image_log"
append logFile $folderDate "" $logPrefix "" $date ".txt"
#ffmpeg command to capture image in background
exec ffmpeg -f dshow -benchmark -i $cctv -s $resolution $filename >& $logFile &
after 3000
}
}
captureImage
thext file code is :
cctv=Integrated Webcam
resolutionX=1920
resolutionY=1080
imagePrefix=ImageCapture
imageFormat=jpg
folderPath=c:/test/
//camera=video=Integrated Webcam,Logitech HD Webcam C525
This code works for me me accept the code from text file were list of parameters are passed.

Script to generate N number of valid ip addresses?

I am new to TCL and trying to learn by doing some simple scripting, I have taken upon to write a simple script which generates valid ip address from a given starting ip address.
I have managed to write one but have run into two problems,
The last octet has a zero getting added in front of the number that is 192.168.1.025
When i specify the starting ip something like this 250.250.5.1 it fails to generate proper ips,
Below is my code:
proc generate {start_addr total_addr} {
if {$total_addr == 0} {return}
regexp {([0-9]+\.)([0-9]+\.)([0-9]+\.)([0-9]+)} $start_addr match a b c d
set filename "output.txt"
set fileId [open $filename "a"]
puts $fileId $a$b$c$d
close $fileId
while {$a<255 && $b <255 && $c <255 && $d < 255 } {
set d [expr {$d + 1}];
set filename "output.txt"
set fileId [open $filename "a"]
puts $fileId $a$b$c$d
close $fileId
set total_addr [expr {$total_addr - 1}];
if {$total_addr == 1} {return}
if {$total_addr > 1 && $d == 255} {
set c [expr {$c + 1}];
set d 1
set filename "output.txt"
set fileId [open $filename "a"]
puts $fileId $a$b$c$d
close $fileId
set total_addr [expr {$total_addr - 1}];
}
if {$total_addr > 1 && $c==255 && $d == 255} {
set b [expr {$b + 1}];
set c 1
set d 1
set filename "output.txt"
set fileId [open $filename "a"]
puts $fileId $a$b$c$d
close $fileId
set total_addr [expr {$total_addr - 1}];
}
if {$total_addr > 1 && $b == 255 && $c == 255 && $d == 255} {
set a [expr {$a + 1}];
set b 1
set c 1
set d 1
set filename "output.txt"
set fileId [open $filename "a"]
puts $fileId $a$b$c$d
close $fileId
set total_addr [expr {$total_addr - 1}];
}
}
}
flush stdout
puts "Please enter the starting IPv4 address with . as delimiter EX: 1.1.1.1"
set start_addr [gets stdin]
regexp {([0-9]+\.)([0-9]+\.)([0-9]+\.)([0-9]+)} $start_addr match a b c d
if {$a <= 255 & $b <= 255 & $c <= 255 & $d <= 255} {
puts "this is a valid ip address"
} else {
puts "this not a valid ip address"
}
flush stdout
puts "Please enter the total number of IPv4 address EX: 1000"
set total_addr [gets stdin]
set result [generate $start_addr $total_addr]
For parsing an IP address the simple way, it is better to use scan. If you know C's sscanf() function, Tcl's scan is very similar (in particular, %d matches a decimal number). Like that, we can do:
if {[scan $start_addr "%d.%d.%d.%d" a b c d] != 4} {
error "some components of address are missing"
}
It's a good idea to throw an error when things go wrong. You can catch them later or just let the script exit, depending on what's right for you. (You still need to check the number range.)
More generally, there's a package in Tcllib that does IP address parsing. It is far more complete than you're likely to need, but it's there.
Second major thing that you should do? Factor out the code to append a string to a file. It's can be a short procedure, short enough that it is obviously right.
proc addAddress {filename address} {
set fileId [open $filename "a"]
puts $fileId $address
close $fileId
}
Then you can replace:
set filename "output.txt"
set fileId [open $filename "a"]
puts $fileId $a$b$c$d
close $fileId
With:
addAddress "output.txt" $a$b$c$d
Less to go wrong. Less noise. (Protip: consider $a.$b.$c.$d there.)
More seriously, your code is just really unlikely to work. It's too complicated. In particular, you should generate one address each time through the loop, and you should concentrate on how to advance the counters right. Using incr to add one to an integer is highly recommended too.
You might try something like this:
incr d
if {$d > 255} {
set d 1
incr c
}
if {$c > 255} {
set c 1
incr b
}
if {$b > 255} {
set b 1
incr a
}
if {$a > 255} {
set a 1
}
But that's less than efficient. We can do better with this:
if {[incr d] > 255} {
set d 1
if {[incr c] > 255} {
set c 1
if {[incr b] > 255} {
set b 1
if {[incr a] > 255} {
set a 1
}
}
}
}
That's better (though actual valid IP addresses have a wider range: you can have a 0 or two in the middle, such as in 127.0.0.1…)
Splitting the address
Apart from using the ip package in Tcllib, there are a few ways to split up an IPv4 "dot-decimal" address and put the octet values into four variables. The one you used was
regexp {([0-9]+\.)([0-9]+\.)([0-9]+\.)([0-9]+)} $start_addr match a b c d
This basically works, but there are a couple of problems with it. The first problem is that the address 1.234.1.234 will be split up as 1. 234. 1. 234, and then when you try to use the incr command on the first three variables you will get an error message (I suppose that's why you used expr {$x + 1} instead of incr). Instead, write
regexp {(\d+)\.(\d+)\.(\d+)\.(\d+)} $start_addr match a b c d
This expression puts the dots outside the capturing parentheses and places integer values into the variables. It's also a good idea to use the shorthand \d (decimal digit) instead of the [0-9] sets. But you could also do this:
regexp -all -inline -- {\d+} $start_addr
where you simply ask regexp to collect all (-all) unbroken sequences of decimal digits and return them as a list (-inline). Since you get the result as a list, you then need to lassign (list assign) them into variables:
lassign [regexp -all -inline -- {\d+} $start_addr] a b c d
But if you can make do without a regular expression, you should. Donal suggested
scan $start_addr "%d.%d.%d.%d" a b c d
which is fine. Another way is to split the string at the dots:
lassign [split $start_addr .] a b c d
(again you get a list as the result and need to assign it to your variables in a second step).
Checking the result
As Donal wrote, it's a good idea whenever you create data from user input (and in many other situations as well) to check that you did get what you expected to get. If you use an assigning regexp the command returns 1 or 0 depending on whether the matched succeeded or failed. This result can be plugged directly into an if invocation:
if {![regexp {(\d+)\.(\d+)\.(\d+)\.(\d+)} $start_addr match a b c d]} {
error "input data didn't match IPv4 dot-decimal notation"
}
Donal already gave an example of checking the result of scan. In this case you check against 4 since the command returns the number of successful matches it managed.
if {[scan $start_addr "%d.%d.%d.%d" a b c d] != 4} {
error "input data didn't match IPv4 dot-decimal notation"
}
If you use either of the list-creating commands (inline regexp or split) you can check the list length of the result:
if {[llength [set result [split $start_addr .]]] == 4} {
lassign $result a b c d
} else {
error "input data didn't match IPv4 dot-decimal notation"
}
This check should be followed by checking all variables for octet values (0-255). One convenient way to do this is like this:
proc isoctet args {
::tcl::mathop::* {*}[lmap octet $args {expr {0 <= $octet && $octet <= 255}}]
}
(It's usually a good idea to break out tests as functions; it's practically the law* if you are using the tests in several places in your code.)
This command, isoctet, takes a number of values as arguments, lumping them together as a list in the special parameter args. The lmap command creates a new list with the same number of elements as the original list, where the value of each element is the result of applying the given script to the corresponding element in the original list. In this case, lmap produces a list of ones and zeros depending on whether the value was a true octet value or not. Example:
input list: 1 234 567 89
result list: 1 1 0 1
The resulting list is then expanded by {*} into individual arguments to the ::tcl::mathop::* command, which multiplies them together. Why? Because if 1 and 0 can be taken as true and false values, the product of a list of ones and zeros happens to be exactly the same as the logical conjunction (AND, &&) of the same list.
result 1: 1 1 0 1
product : 0 (false)
result 2: 1 1 1 1
product : 1 (true)
So,
if {![isoctet $a $b $c $d]} {
error "one of the values was outside the (0, 255) range"
}
Generating new addresses
Possibly the least sexy way to generate a new address is to use a ready-made facility in Tcl: binary.
binary scan [binary format c* [list $a $b $c $d]] I n
This invocation first converts a list of integer values (while constraining them to octet size) to a bit string, and then interprets that bit string as a big-endian 32-bit integer (if your machine uses little-endian integers, you should use the conversion specifier i instead of I).
Increment the number. Wheee!
incr n
Convert it back to a list of 8-bit values:
binary scan [binary format I $n] c4 parts
The components of parts are now signed 8-bit integers, i.e. the highest value is 127, and the values that should be higher than 127 are now negative values. Convert the values to unsigned (0 - 255) values like this:
lassign [lmap part $parts {expr {$part & 0xff}}] a b c d
and join them up to a dot-decimal string like this:
set addr [join [list $a $b $c $d] .]
If you want more than one new address, repeat the process.
Documentation: binary, error, expr, if, incr, join, lassign, llength, lmap, mathop, proc, regexp, scan, set, split, {*}
lmap is a Tcl 8.6 command. Pure-Tcl implementations for Tcl 8.4 and 8.5 are available here.
*) If there were any laws. What you must learn is that these rules are no different than the rules of the Matrix. Some of them can be bent. Others can be broken.
proc ip_add { ip add } {
set re "^\\s*(\\d+)\.(\\d+)\.(\\d+)\.(\\d+)\\s*$"
if [regexp $re $ip match a b c d] {
set x [expr {(($a*256+$b)*256+$c)*256+$d+$add}]
set d [expr {int(fmod($x,256))}]
set x [expr {int($x/256)}]
set c [expr {int(fmod($x,256))}]
set x [expr {int($x/256)}]
set b [expr {int(fmod($x,256))}]
set x [expr {int($x/256)}]
set a [expr {int(fmod($x,256))}]
return "$a.$b.$c.$d"
} else {
puts stderr "invalid ip $ip"
exit 1
}
}
set res [ip_add "127.0.0.1" 512]
puts "res=$res"

How to read number count of words?

How to read number count of words?
Lines has this format:
vertices_count
X, Y
X, Y
X, Y
(X, Y pair can be in the same line)
for example:
3
12.5, 56.8
12.5, 56.8
12.5, 56.8
I would like to read vertices_count number of words(escaping comma):
So for above example reading words should be:
12.5 56.8 12.5 56.8 12.5 56.8
set fh [open f r]
gets $fh num
read $fh data
close $fh
set number_re {-?\d+(?:\.\d*)?|-?\d*\.\d+}
set vertices {}
foreach {_ x y} [regexp -inline -all "($number_re),\\s*($number_re)" $data] {
lappend vertices $x $y
if {[llength $vertices] == $num * 2} break
}
puts $vertices
# => 12.5 56.8 12.5 56.8 12.5 56.8
while {[llength $vertices] < $num * 2} {
gets $fh line
foreach {_ x y} [regexp -inline -all "($number_re),\\s*($number_re)" $line] {
lappend vertices $x $y
if {[llength $vertices] == $num * 2} break
}
}
close $fh
I'm still not clear exactly what you are after. Here is some code to read data from a named file. Judging from your other question, you can have several sets of data in your input stream and this code returns them all as a list. Each element of the list is one set of coordinates
# Read the input from file
set fil [open filename.file]
set input [read $fil]
close $fil
set data [list]; # No output so for
set seekCount yes; # Next token is a vertex count
foreach token [string map {, " "} $input] {
# Convert commas to spaces
if {$seekCount} {
set nCoords [expr $token * 2];
# Save number of coordinates
set datum [list]; # Clean out vertex buffer
} else {
lappend datum $token; # Save coordinate
incr nCoords -1
if {$nCoords <= 0} {
# That was the last coordinate
lappend data $datum; # Append the list of coordinates
set seekCount yes; # and look for anopther count
}
}
}
This is a very quick-and-dirty solution, which makes no attempt to handle errors. One thing, however that it will cope with is variable amounds of whitespace and missing whitespace after the commas.
Good luck, I hope this helps.
This procedure first reads a count line, then reads that number of lines and puts as a list into $varName. It returns the number of elements in $varName, or -1 if EOF occured before a count was read.
proc getNLines {stream varName} {
upvar 1 $varName lines
set lines {}
if {[gets $stream n] < 0} {
return -1
}
while {$n > 0} {
if {[gets $stream line] < 0} {
error "bad data format"
}
lappend lines $line
incr n -1
}
return [llength $lines]
}
while {[getNLines stdin lines] >= 0} {
# ...
}

how to check adjacent values in tcl list?

I have a list like
set val [ list Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 ]
now i want to put it in a loop and execute some commands over each range
like
set number 0
set pattern 0
foreach n $val {
if {$pattern == 0} {
set current $n
regexp {(.*/)(\d+)} $n - pattern number
continue
}
regexp {(.*/)(\d+)} $n - match1 match2
if {$match1 == $pattern} {
#puts "someproc $current - match2"
}
}
I am unable to get this work the output should be like for ech pair or singular value found
someproc Fa2/0/1 - 24
someproc Gi1/0/13 - 23
someproc Gi1/1/1 - 1 #for singular values
someproc Gi2/0/1 - 1
EDIT : i have a list of such data like :
Gi3/0/1 Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 Te1/0/1
where you can say each data can be of type Gi3/0/ or Gi2/0/ or Fa2/0/ these reperesent some range of ports on cisco swicth.Now for every type i need to execute some command for a range.Again taking the above list i can get.
somecommand Gi3/0/1 - 1 # there is only one `Gi3/0/` with number 1.
somecommand Fa2/0/1 - 24 # range of `Fa2/0/` is 1 to 24
similarly,
somecommand Gi1/0/13 - 23
somecommand Gi1/1/1 - 1
and so on
#!/usr/bin/tcl
## Assumptions:
## The pattern will always be X/X/X
## The values are given in list
set val_list [list Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1]
array set pattern {}
foreach item $val_list {
set parent [file dir $item]
set val [file tail $item]
if {[info exists pattern($parent,L)] && [info exists pattern($parent,H)] } {
if {$pattern($parent,L) > $val } {
set pattern($parent,L) $val
} elseif { $pattern($parent,H) < $val} {
set pattern($parent,H) $val
}
} else {
set pattern($parent,L) $val
set pattern($parent,H) $val
}
}
array set count {}
foreach pat [array names pattern] {
set pat [lindex [split $pat ,] 0]
if {![info exists count($pat)] } {
puts "$pat $pattern($pat,L) - $pattern($pat,H)"
set count($pat) 1
}
}
/*The output will be
Gi1/0 13 - 23
Fa2/0 1 - 24
Gi2/0 1 - 1
Gi1/1 1 - 1
*/
Hope this is what you are requesting for. I used array "count" to remove duplicate entries in output, which needs to be avoided. Hope if someone can suggest any better way. And FYI I am using 8.4 version of TCL.
If you are not sure how arrays, work, you can edit the code you posted as an answer to this code:
set number 0
set pattern 0
set current 0
set result [list Gi3/0/1 Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 Te1/0/1]
foreach n [lsort $result] {
if {$pattern == 0} {
set current $n
regexp {(.*/)(\d+)} $n - pattern number
continue
}
regexp {(.*/)(\d+)} $n - match1 match2
if {$match1 == $pattern} {
set number $match2
} else {
puts "$current - $number"
set pattern $match1
set number $match2
set current $n
}
}
That works for me :)
The output (note that I sorted the list first so you only have to worry about the increasing $number or $match2 while not having to bother too much about the $pattern):
Fa2/0/1 - 24
Gi1/0/13 - 23
Gi1/1/1 - 1
Gi2/0/1 - 1
Gi3/0/1 - 1
Here is my solution, which does not use array (nothing is wrong with array, my solution just don't need it), and it does it in one pass (i.e. only one loop).
set val [ list Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 ]
set lastPattern ""
set lastNumber 0
lappend val x/1/1; # Add a trailer to ease processing
foreach item $val {
# If item=Fa2/0/1, then pattern=Fa2/0 and number=1
set pattern [file dirname $item]
set number [file tail $item]
if {$pattern == $lastPattern} {
# We have seen this pattern before
puts "$pattern/$lastNumber - $number"
set lastPattern ""
} else {
# This is a new pattern, print the old one if applicable then
# save the pattern and number for later processing
if {$lastPattern != ""} {
puts "$lastPattern/$lastNumber - $lastNumber"
}
set lastPattern $pattern
set lastNumber $number
}
}
set val [lrange $val end-1]; # Remove the trailer
If you want to compare adjacent list elements, it might be cleaner to use a C-style for loop:
for {set i 0} {$i < [llength $val] - 1} {incr i} {
set current [lindex $val $i]
set next [lindex $val [expr {$i+1}]]
# ...
}
Or, a bit more esoteric
set l {a b c d e f g}
foreach current [lrange $l 0 end-1] \
next [lrange $l 1 end] {
puts "$current $next"
}
outputs
a b
b c
c d
d e
e f
f g
You could even write a new control structure, similar to Ruby's each_cons
proc foreach_cons {vars list body} {
foreach varname $vars {upvar 1 $varname $varname}
set numvars [llength $vars]
for {set i 0} {$i <= [llength $list]-$numvars} {incr i} {
lassign [lrange $list $i [expr {$i + $numvars}]] {*}$vars
uplevel 1 $body
}
}
foreach_cons {a b c} $l {puts "$a $b $c"}
a b c
b c d
c d e
d e f
e f g
Why don't you loop over pairs of the list?
foreach {v1 v2} $val {
someproc $v1 $v2
}
You might check if both values are similar, extract the parts that you need etc.
I came up with a awkward solution of my own :
where reslut is the list :
Gi3/0/1 Fa2/0/1 Fa2/0/24 Gi1/0/13 Gi1/0/23 Gi1/1/1 Gi2/0/1 Te1/0/1
#
set number 0
set pattern 0
set last_element [lindex $result end]
set first_element [lindex $result 0]
foreach n $result {
if {$pattern == 0} {
set current $n
set count 0
regexp {(.*/)(\d+)} $n - pattern number
continue
}
regexp {(.*/)(\d+)} $n - match1 match2
if {$match1 == $pattern} {
set count 0
puts " $current - $match2"
continue
} else {
if {"$last_element" == "$n"} {
puts "$last_element"
}
if {"$first_element" == "$current"} {
puts "$first_element"
}
incr count
if {"$count" == 1} {
set pattern $match1
set current $n
continue
} else {
if {$match1 != $pattern} {
puts "$current"
}
}
set pattern $match1
}
set current $n
}
This solution is a little shorter, but requires Tcl 8.5.
First, create a dictionary structure with the first two fields as key and subkey, and collect lists of values from the third field as dictionary values:
set data {}
foreach v $val {
lassign [split $v /] a b c
if {![dict exists $data $a $b]} {
dict set data $a $b {}
}
dict with data $a {
lappend $b $c
set b [lsort –integer $b]
}
}
Then iterate over this dictionary structure, calling the someproc command for each combination of key, subkey, first and last value.
dict for {a v} $data {
dict for {b v} $v {
someproc $a/$b/[lindex $v 0] - [lindex $v end]
}
}
Documentation: dict, foreach, if, lappend, lassign, lindex, set, split