make-probes.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3
   4 proc debug {level str} {
   5     global debug_level
   6     if {$level <= $debug_level} { puts stderr "debug\[$level] $str" }
   7 }
   8
   9 proc manyset {list args} {
  10     foreach val $list var $args {
  11         upvar 1 $var my
  12         set my $val
  13     }
  14 }
  15
  16
  17 proc start_gen {seed} {
  18     global getlog_log
  19     random-bytes-init $seed
  20     set getlog_log {}
  21 }
  22
  23 proc packet-len {p} { expr {[string length $p]/2} }
  24
  25 proc packet-csum-ip {packet} {
  26     set cs 0
  27     append packet 00
  28     while {[regexp {^([0-9a-f]{4})(.*)$} $packet dummy this packet]} {
  29         set cs [expr "\$cs + 0x$this"]
  30         debug 7 [format "0x%s 0x%08x" $this $cs]
  31     }
  32     return [expr {(($cs & 0xffff) + (($cs >> 16) & 0xffff)) ^ 0xffff}]
  33 }
  34
  35 proc packet-fromstring {s} {
  36     binary scan $s H* y
  37     return $y
  38 }
  39
  40 namespace eval Random-Bytes {
  41     namespace export random-bytes random-bytes-init
  42
  43     proc random-bytes-init {seed} {
  44         variable fh
  45         catch { set h $fh; unset fh; close $h }
  46         set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
  47         fconfigure $fh -translation binary
  48     }
  49     proc random-bytes {n} {
  50         variable fh
  51         set x [read $fh $n]
  52         if {[string length $x] != $n} {
  53             set h $fh; unset fh; close $h
  54             error "openssl bf-ofb exited unexpectedly"
  55         }
  56         set y [packet-fromstring $x]
  57         return $y
  58     }
  59 }
  60
  61 namespace import Random-Bytes::*
  62
  63 proc choice-int {min max} {
  64     set rv 0x[random-bytes 3]
  65     return [expr {
  66         int( double($rv) / double(0x1000000) * double($max+1-$min) )
  67         + $min
  68     }]
  69 }
  70
  71 proc choice-prob {cv def} {
  72     set prob [config $cv $def]
  73     set rv 0x[random-bytes 3]
  74     return [expr {$rv < double($prob)*0x1000000}]
  75 }
  76
  77 proc choice-mult {args} {
  78     if {!([llength $args] % 2)} { error "choice-mult must have default" }
  79     set h 0x[random-bytes 3]
  80     set x [expr { double($h) / double(0x1000000) }]
  81     set cump 0.0
  82     set def [lindex $args end]
  83     set args [lreplace $args end end]
  84     foreach {val p} $args {
  85         set cump [expr {$cump + double($p)}]
  86         if {$x < $cump} { return $val }
  87     }
  88     return $def
  89 }
  90
  91 proc getlog {msg} {
  92     upvar #0 getlog_log log
  93     append log " $msg"
  94     debug 2 "getlog $msg"
  95 }
  96
  97 proc config {cv def} {
  98     upvar #0 config/$cv v
  99     if {[info exists v]} { return $v }
 100     return $def
 101 }
 102
 103
 104 proc define {enum val name argnames body} {
 105     upvar #0 enum/val2name/$enum v2n
 106     upvar #0 enum/name2val/$enum n2v
 107     set v2n($val) $name
 108     set n2v($name) $val
 109     proc enum/val/$enum/$val $argnames $body
 110 }
 111
 112 proc depending-on {scope enum_and_var mtu mtuadjust args} {
 113     upvar 1 $enum_and_var val
 114     set mtu [expr {$mtu + $mtuadjust}]
 115     set procname enum/val/$scope-$enum_and_var/[format %d $val]
 116     if {[choice-prob $enum_and_var-unstruct 0.1] ||
 117             [catch { info body $procname }]} {
 118         getlog (junk)
 119         get-for $scope-fill
 120         get data rand 0 $mtu 1
 121         return $data
 122     } else {
 123         uplevel 1 [list $procname] $mtu $args
 124     }
 125 }
 126
 127
 128 proc get-for {scope} {
 129     upvar 1 get/scope ns
 130     set ns $scope
 131 }
 132
 133 proc get {variable kind args} {
 134     upvar 1 get/scope scope
 135     upvar 1 $variable var
 136     set var [eval [list get/$kind $scope $variable] $args]
 137 }
 138
 139 proc get-config/number {val min max} { return $val }
 140 proc get-config/v4addr {val} {
 141     if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
 142         error "bad v4addr ?$val?"
 143     }
 144     return [format 0x%02x%02x%02x%02x $a $b $c $d]
 145 }
 146
 147 proc get-config {variable def kind args} {
 148     # args currently ignored
 149     upvar 1 get/scope scope
 150     upvar 1 $variable var
 151     set val [config $scope-$variable $def]
 152     set var [eval [list get-config/$kind $val] $args]
 153 }
 154
 155 proc get-enum-got {s v rv} {
 156     upvar #0 enum/val2name/$s-$v v2n
 157     if {[info exists v2n($rv)]} {
 158         getlog "$v=$v2n($rv)\[$rv]"
 159     } else {
 160         getlog "$v=$rv"
 161     }
 162     return $rv
 163 }
 164
 165 proc get/enum-rand {s v min max} {
 166     set rv [choice-int $min $max]
 167     return [get-enum-got $s $v $rv]
 168 }
 169
 170 proc get/enum-def {s v} {
 171     upvar #0 enum/val2name/$s-$v v2n
 172     set rv [choice-int 1 [array size v2n]]
 173     set rv [lindex [lsort [array names v2n]] [expr {$rv-1}]]
 174     return [get-enum-got $s $v $rv]
 175 }
 176
 177 proc get/enum {s v min max prand} {
 178     get-for $s-$v
 179     get any choice $prand
 180     if {$any} {
 181         return [get/enum-rand $s $v $min $max]
 182     } else {
 183         return [get/enum-def $s $v]
 184     }
 185 }
 186
 187 proc get/number {s v min max} {
 188     set rv [choice-int $min $max]
 189     getlog "$v=$rv"
 190     return $rv
 191 }
 192
 193 proc get/hex {s v min max} {
 194     set rv [choice-int $min $max]
 195     getlog [format %s=0x%x $v $rv]
 196     return $rv
 197 }
 198
 199 proc get/hex32 {s v} {
 200     set rv [random-bytes 4]
 201     getlog "$v=0x$rv"
 202     return 0x$rv
 203 }
 204
 205 proc get/flag {s v defprob} {
 206     set rv [choice-prob $s-$v $defprob]
 207     if {$rv} { getlog "$v" } else { getlog "!$v" }
 208     return $rv
 209 }
 210
 211 proc get/choice {s v defprob} {
 212     set rv [choice-prob $s-$v $defprob]
 213     if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
 214     return $rv
 215 }
 216
 217 proc get/rand {s v minlen maxlen blockbytes} {
 218     get-for $s-$v
 219     if {$maxlen<0} { getlog (full!); return {} }
 220     get l number [expr {$minlen/$blockbytes}] [expr {$maxlen/$blockbytes}]
 221     return [random-bytes [expr {$l*$blockbytes}]]
 222 }
 223
 224 proc get/ip-timestamp {s v} {
 225     set rv [expr {[clock seconds] | 0x80000000}]
 226     getlog "$v=[format %x $rv]"
 227     return $rv
 228 }
 229
 230 proc get/v4addr {s v} {
 231     set rv 0x
 232     set p {}
 233     set d {}
 234     for {set i 0} {$i<4} {incr i} {
 235         set b [random-bytes 1]
 236         append rv $b
 237         append p $d [format %d 0x$b]
 238         set d .
 239     }
 240     getlog "$v=$p"
 241     return $rv
 242 }
 243
 244 proc get/choice-mult {s v args} {
 245     set rv [eval choice-mult $args]
 246     getlog "($rv)"
 247     return $rv
 248 }
 249
 250 proc get/string {s v minlen maxlen first rest} {
 251     set o {}
 252     set now $first
 253     for {set l [choice-int $minlen $maxlen]} {$l>0} {incr l -1} {
 254         set cn [choice-int 0 [expr {[string length $now]-1}]]
 255         append o [string index $now $cn]
 256         set now $rest
 257     }
 258     getlog "$v=\"$o\""
 259     return [packet-fromstring $o]
 260 }
 261
 262 proc get/ntstring {s v minlen maxlen first rest} {
 263     set s [get/string $s $v $minlen $maxlen $first $rest]
 264     append s 00
 265     append s [random-bytes $maxlen]
 266     return [string range $s 0 [expr {$maxlen*2-1}]]
 267 }
 268
 269 namespace eval Assembler {
 270     namespace export assemble assembly-overwrite
 271
 272     proc assemble {outvarname format} {
 273         # format should look like those RFC diagrams.  +-+-+ stuff and
 274         # good formatting is mandatory.  You can have a single data
 275         # item at the end ending in ..., which means append that data
 276         # item.
 277         #
 278         # Field names are converted to lowercase; internal spaces
 279         # are replaced with _.  They are then assumed to be
 280         # variable names in the caller's scope.  The packet is
 281         # assembled from those values (which must all be set)
 282         # and stored in $varname in the caller's scope.
 283         #
 284         # Variables ?_whatever will be *set* with the location of the
 285         # field in the string (in internal format); the corresponding
 286         # `whatever' (with the ?_ stripped) will be read when assembling.
 287         #
 288         # Field names starting with digits are literal values instead.
 289
 290         variable cache
 291         upvar 1 $outvarname out
 292         if {[catch { set parsed $cache($format) }]} {
 293             set parsed [parse $format]
 294             set cache($format) $parsed
 295         }
 296
 297         manyset $parsed outbytes lout
 298         set out [string repeat 00 $outbytes]
 299         foreach {?_location varname locvarname} $lout {
 300             if {[regexp {^[0-9]} $varname]} {
 301                 set value $varname
 302             } else {
 303                 set value [uplevel 1 [list set $varname]]
 304             }
 305             if {[string length $locvarname]} {
 306                 upvar 1 $locvarname lv
 307                 set lv ${?_location}
 308             }
 309             if {[catch {
 310                 assembly-overwrite out location $value
 311             } emsg]} {
 312                 global errorInfo errorCode
 313                 error $emsg \
 314                         "$errorInfo\n    setting\n$varname at ${?_location}" \
 315                         $errorCode
 316             }
 317         }
 318     }
 319
 320     proc parse {format} {
 321         set lno 0
 322         set outbytes 0
 323         set atend 0
 324         debug 7 "ASSEMBLY $format"
 325         set format [exec expand << $format]
 326         foreach l [split $format "\n"] {
 327             incr lno
 328             if {[regexp -nocase {^ *\| +\| *$} $l]} {
 329                 if {![info exists wordbits]} {
 330                     error "vspace not in data @$lno\n?$l?"
 331                 }
 332                 incr words
 333             } elseif {[regexp -nocase {^ *[|? a-z0-9.]+$} $l]} {
 334                 if {[info exists words]} {
 335                     error "data without delimline @$lno\n?$l?"
 336                 }
 337                 set words 1
 338                 set cue $l
 339             } elseif {[regexp {^ *[-+]+ *$} $l]} {
 340                 set wordbits 0
 341                 set newlineform {}
 342                 while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
 343                     set atpos([string length $before]) $wordbits
 344                     incr wordbits
 345                     set l "$before=$after"
 346                     append newlineform "@[string length $before]:$wordbits "
 347                 }
 348                 incr wordbits -1
 349                 append newlineform $wordbits
 350                 if {[info exists lineform]} {
 351                     if {"$newlineform" != "$lineform"} {
 352  error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
 353                     }
 354                     if {![info exists words] || $words<0} {
 355                         error "consecutive delimlines @$lno\n?$l?"
 356                     }
 357                     incr outbytes [expr {$words*$wordbits/8}]
 358                     set l $cue
 359                     while {[regexp -nocase \
 360                             {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *\.* *)\|(.*)$} \
 361                             $l dummy before midpart after]} {
 362                         debug 7 "RWORKG ?$l?"
 363                         if {$atend} {
 364                             error "two things at end @$lno\n?$l?"
 365                         }
 366                         set varname [string tolower [string trim $midpart]]
 367                         if {[regexp {(.*[a-z0-9])\s*\.\.\.$} $varname \
 368                                 dummy realvarname]} {
 369                             set varname $realvarname
 370                             set atend 1
 371                         }
 372                         set varname [string map {{ } _} $varname]
 373                         set p1 [string length $before]
 374                         set p2 [expr {
 375                             [string length $before] +
 376                             [string length $midpart] + 1
 377                         }]
 378                         if {![info exists atpos($p1)] ||
 379                             ![info exists atpos($p2)]} {
 380  error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
 381                         }
 382                         set bit1 [expr {
 383                             $outbytes*8
 384                             - $words*$wordbits
 385                             + $atpos($p1)
 386                         }]
 387                         set bitlen [expr {
 388                             $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
 389                         }]
 390                         if {$atend} {
 391                             if {$bit1 % 8} {
 392                                 error "atend not at byte @$lno\n?$l?"
 393                             }
 394                             set outbytes [expr {$bit1/8}]
 395                             set location [list $bit1 0 $varname]
 396                         } else {
 397                             set location [list $bit1 $bitlen $varname]
 398                         }
 399                         if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
 400                             debug 7 "LOCATING $varname $location"
 401                             set locvarname $varname
 402                             set varname $realvarname
 403                         } else {
 404                             set locvarname {}
 405                         }
 406                         lappend lout $location $varname $locvarname
 407                         set l "$before="
 408                         append l [string repeat = [string length $midpart]]
 409                         append l |$after
 410                     }
 411                     debug 7 "REMAIN ?$l?"
 412                     if {![regexp {^[ =]*\|? *$} $l]} {
 413                         error "unclear @$lno\n?$l?"
 414                     }
 415                 } else {
 416                     if {$wordbits % 8 || $wordbits >32} {
 417                         error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 418                     }
 419                     set lineform $newlineform
 420                 }
 421                 catch { unset words }
 422             } elseif {[regexp {^ *$} $l]} {
 423             } else {
 424                 error "huh? @$lno ?$l?"
 425             }
 426         }
 427         debug 7 "ASSEMBLY\n$outbytes\n$lout\n"
 428         return [list $outbytes $lout]
 429     }
 430
 431     proc assembly-overwrite {outvarname locvarnameex value} {
 432         upvar 1 $outvarname out
 433         upvar 1 ?_$locvarnameex location
 434         manyset $location bit1 bitlen diag
 435         if {$bitlen > 0 && $bitlen != 32 && $value >= (1<<$bitlen)} {
 436             error "$diag $value >= 2**$bitlen"
 437         }
 438         if {!($bit1 % 8) && !($bitlen % 8)} {
 439             set char0no [expr {$bit1/4}]
 440             set charlen [expr {$bitlen/4}]
 441             set chareno [expr {$char0no + $charlen -1}]
 442             if {$bitlen > 0} {
 443  debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
 444                 set repl [format %0${charlen}x $value]
 445                 set out [string replace $out $char0no $chareno $repl]
 446             } else {
 447  debug 8 "ASSEMBLY-ADD $diag (@$bit1)"
 448                 # bitlen==0 => append
 449                 set out [string range $out 0 $chareno]
 450                 append out $value
 451             }
 452         } else {
 453             while {$bitlen > 0} {
 454                 set byteno [expr {$bit1 / 8}]
 455                 set char0no [expr {$byteno*2}]
 456                 set char1no [expr {$char0no+1}]
 457                 set bytebit [expr {128>>($bit1 % 8)}]
 458                 set byte 0x[string range $out $char0no $char1no]
 459                 debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
 460                 set byte [expr {
 461                     ($value & (1<<($bitlen-1)))
 462                     ? ($byte | $bytebit)
 463                     : ($byte & ~$bytebit)
 464                 }]
 465                 set out [string replace $out $char0no $char1no \
 466                         [format %02x $byte]]
 467  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
 468                 incr bitlen -1
 469                 incr bit1
 470             }
 471         }
 472     }
 473 }
 474 namespace import Assembler::*
 475
 476 proc gen_1_ip {mtu source_spec dest_spec} {
 477     # RFC791
 478     upvar #0 ip_proto proto
 479     upvar #0 ip_source source
 480     upvar #0 ip_dest dest
 481
 482     set source $source_spec
 483     set dest $dest_spec
 484
 485     get-for ip
 486     set version 4
 487     get tos hex 0x00 0xff
 488     get id number 0x0000 0xffff
 489     get df flag 0.5
 490     if {$df || ![choice-prob ip-midfrag 0.05]} {
 491         set mf 0
 492         set frag 0
 493     } {
 494         get mf flag 0.5
 495         get frag number 0 0x1fff
 496     }
 497     get-config ttl 255 number 0 255
 498     get proto enum 1 255 0.05
 499     set flags [expr {$df*2 + $mf}]
 500
 501     set header_checksum 0
 502     set ihl 0
 503     set total_length 0
 504     assemble ip {
 505    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 506    |Version| ? IHL |TOS            |       ? Total Length          |
 507    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 508    |         Id                    |Flags|      Frag               |
 509    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 510    |  TTL          |    Proto      |      ? Header Checksum        |
 511    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 512    |                       Source                                  |
 513    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 514    |                    Dest                                       |
 515    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 516     }
 517     # we don't do any IP options
 518
 519     set ihl [packet-len $ip]
 520     if {$ihl % 4} { error "ihl not mult of 4 bytes" }
 521     assembly-overwrite ip ihl [expr {$ihl / 4}]
 522
 523     set body [depending-on ip proto $mtu -$ihl]
 524     set total_length [expr {[packet-len $ip] + [packet-len $body]}]
 525
 526     assembly-overwrite ip total_length $total_length
 527     assembly-overwrite ip header_checksum [packet-csum-ip $ip]
 528
 529     append ip $body
 530     return $ip
 531 }
 532
 533 define ip-proto 1 icmp {mtu} {
 534     # RFC792
 535     get-for icmp
 536     get type enum 0 255 0.2
 537     manyset [depending-on icmp type $mtu -4] body code
 538     if {![string length $code]} { get code number 0 255 }
 539     set checksum 0
 540     assemble icmp {
 541    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 542    |     Type      |     Code      |        ? Checksum             |
 543    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 544    |     Body ...                                                  |
 545    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 546     }
 547     assembly-overwrite icmp checksum [packet-csum-ip $icmp]
 548     return $icmp
 549 }
 550
 551 proc define-icmp-type-vanilla {num name} {
 552     define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
 553 }
 554 proc icmp-vanilla {mbl typename} {
 555     get-for icmp-$typename
 556     get code enum 0 255 0.4
 557     get body rand 0 $mbl 1
 558     return [list $body $code]
 559 }
 560
 561 define-icmp-type-vanilla 3 unreach
 562 define icmp-unreach-code 0 net {} {}
 563 define icmp-unreach-code 1 host {} {}
 564 define icmp-unreach-code 2 proto {} {}
 565 define icmp-unreach-code 3 port {} {}
 566 define icmp-unreach-code 4 fragneeded {} {}
 567 define icmp-unreach-code 5 sourceroutefail {} {}
 568
 569 define-icmp-type-vanilla 11 timeout
 570 define icmp-timeout-code 0 intransit {} {}
 571 define icmp-timeout-code 1 fragment {} {}
 572
 573 define-icmp-type-vanilla 12 parameters
 574 define icmp-parameters-code 0 seepointer {} {}
 575
 576 define-icmp-type-vanilla 4 sourcequench
 577 define icmp-sourcequench-code 0 quench {} {}
 578
 579 define icmp-type 5 redirect {mbl} {
 580     get-for icmp-redirect
 581     get code enum 0 255 0.4
 582     get gateway v4addr
 583     get data rand 0 [expr {$mbl-4}] 1
 584     assemble body {
 585    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 586    |                 Gateway                                       |
 587    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 588    |     Data ...                                                  |
 589    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 590     }
 591     return [list $body $code]
 592 }
 593
 594 define icmp-redirect-code 0 net {} {}
 595 define icmp-redirect-code 1 host {} {}
 596 define icmp-redirect-code 2 net+tos {} {}
 597 define icmp-redirect-code 3 host+tos {} {}
 598
 599 define icmp-type 8 ping {mbl} { icmp-echo $mbl }
 600 define icmp-type 0 pong {mbl} { icmp-echo $mbl }
 601 proc icmp-echo {mbl} {
 602     get-for icmp-echo
 603     get code enum 0 255 0.4
 604     get id hex 0 0xffff
 605     get seq hex 0 0xffff
 606     get data rand 0 [expr {$mbl-8}] 1
 607     assemble body {
 608    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 609    |       Id                      |        Seq                    |
 610    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 611    |     Data ...                                                  |
 612    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 613     }
 614     return [list $body $code]
 615 }
 616 define icmp-echo-code 0 echo {} {}
 617
 618 define icmp-type 13 timestamp {mbl} { icmp-timestamp }
 619 define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
 620 proc icmp-timestamp {} {
 621     get-for icmp-timestamp
 622     get code enum 0 255 0.4
 623     get id hex 0 0xffff
 624     get seq hex 0 0xffff
 625     get originate ip-timestamp
 626     get receive ip-timestamp
 627     get transmit ip-timestamp
 628     assemble body {
 629    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 630    |           Id                  |        Seq                    |
 631    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 632    |     Originate                                                 |
 633    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 634    |     Receive                                                   |
 635    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 636    |     Transmit                                                  |
 637    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 638     }
 639     return [list $body $code]
 640 }
 641 define icmp-timestamp-code 0 timestamp {} {}
 642
 643 define icmp-type 15 inforequest {mbl} { icmp-inforeq }
 644 define icmp-type 16 inforeply {mbl} { icmp-inforeq }
 645 proc icmp-inforeq {} {
 646     get-for icmp-inforeq
 647     get code enum 0 255 0.4
 648     get id hex 0 0xffff
 649     get seq hex 0 0xffff
 650     assemble body {
 651    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 652    |           Id                  |        Seq                    |
 653    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 654     }
 655     return [list $body $code]
 656 }
 657 define icmp-inforeq-code 0 timestamp {} {}
 658
 659 # MAYADD ICMP traceroute RFC1393
 660 # MAYADD ICMP router discovery RFC1256
 661
 662 proc port-pair {scope} {
 663     get-for $scope
 664
 665     get style choice-mult \
 666             request 0.15 \
 667             reply 0.15 \
 668             servers 0.20 \
 669             random
 670
 671     if {"$style" != "random"} {
 672         get port enum-def
 673         set def_port $port
 674     } else {
 675         set def_port x
 676     }
 677     if {"$style" != "servers"} {
 678         get port enum-rand 0 0xffff
 679         set rand_port $port
 680     }
 681     switch -exact $style {
 682         random  { set source_port $rand_port; set dest_port $rand_port }
 683         request { set source_port $rand_port; set dest_port $def_port }
 684         reply   { set source_port $def_port;  set dest_port $rand_port }
 685         servers { set source_port $def_port;  set dest_port $def_port }
 686     }
 687     return [list $source_port $dest_port $def_port $style]
 688 }
 689
 690
 691 define ip-proto 4 ip {mtu} {
 692     # RFC2003
 693     get-for ip-ip
 694     get source v4addr
 695     get dest v4addr
 696     gen_1_ip $mtu $source $dest
 697 }
 698
 699
 700 define ip-proto 2 igmp {mtu} {
 701     get-for igmp
 702     get type enum 0 255 0.5
 703     get timeout number 0 255
 704     get group v4addr
 705     set checksum 0
 706     set extra {}
 707     assemble igmp {
 708    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 709    |      Type     |   Timeout     |         ? Checksum            |
 710    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 711    |                         Group                                 |
 712    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 713    |                       ? Extra ...                             |
 714    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 715     }
 716
 717     if {[choice-prob igmp-extra 0.3]} {
 718         get extra rand 1 [expr {$mtu - [packet-len $igmp]}] 1
 719         assembly-overwrite igmp extra $extra
 720     }
 721
 722     assembly-overwrite igmp checksum [packet-csum-ip $igmp]
 723     return $igmp
 724 }
 725
 726 define igmp-type 17 membquery {} {}
 727 define igmp-type 16 membreport {} {}
 728 define igmp-type 23 leavegroup {} {}
 729 define igmp-type 18 membreport {} {}
 730
 731
 732 define ip-proto 51 ah {mtu} {
 733     # RFC1826
 734     get-for ah
 735     get next number 0 255
 736     get reserved hex 0 0xffff
 737     get spi hex32
 738     get auth_data rand 0 [expr {$mtu-8}] 4
 739     set length [packet-len $auth_data]
 740     assemble ah {
 741      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 742      | Next          |   Length      |           RESERVED            |
 743      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 744      |                    SPI                                        |
 745      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 746      |                 Auth Data ...                                 |
 747      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 748     }
 749     get payload rand 0 [expr {$mtu - [packet-len $ah]}] 1
 750     append ah $payload
 751     return $ah
 752 }
 753
 754
 755 define ip-proto 17 udp {mtu} {
 756     # RFC768
 757     get-for udp
 758
 759     set csum_mode [choice-mult \
 760             checksum_bad 0.10 \
 761             checksum_none 0.20 \
 762             checksum_good]
 763     manyset [port-pair udp] source_port dest_port def_port style
 764
 765     if {"$style" != "random"} {
 766         set port $def_port
 767         set data [depending-on udp port $mtu -8 $style]
 768     } else {
 769         get data rand 0 [expr {$mtu-8}] 1
 770     }
 771
 772     set length 0
 773     set checksum 0
 774     assemble udp {
 775    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 776    |       Source Port             |        Dest Port              |
 777    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 778    |       ? Length                |      ? Checksum               |
 779    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 780    |     Data ...                                                  |
 781    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 782     }
 783     set udp_length [packet-len $udp]
 784     assembly-overwrite udp length $udp_length
 785
 786     if {"$csum_mode" == "checksum_none"} {
 787         set checksum 0
 788         getlog (nocsum)
 789     } else {
 790         global ip_source ip_dest ip_proto
 791         assemble pseudo {
 792    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 793    |       IP Source                                               |
 794    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 795    |       IP Dest                                                 |
 796    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 797    |       0       | IP Proto      |        UDP length             |
 798    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 799         }
 800         set checksum [packet-csum-ip "$pseudo$udp"]
 801         if {!$checksum} { set checksum 0xffff }
 802         if {"$csum_mode" == "checksum_bad"} {
 803             get csumerror hex 1 0xffff
 804             set checksum [expr {$checksum ^ $csumerror}]
 805         }
 806     }
 807     assembly-overwrite udp checksum $checksum
 808     return $udp
 809 }
 810
 811 define udp-port 50 remailck {mtu style} {
 812     # RFC1339
 813     get-for remailck
 814     if {"$style" == "request"} {
 815         get what choice-mult \
 816                 req-baduser 0.15 \
 817                 req-auth 0.15 \
 818                 resp-ok 0.15 \
 819                 resp-auth 0.15 \
 820                 req-user
 821     } else {
 822         get what choice-mult \
 823                 req-baduser 0.15 \
 824                 req-auth 0.15 \
 825                 resp-auth 0.15 \
 826                 req-user 0.15 \
 827                 resp-ok
 828     }
 829     switch -exact $what {
 830         req-user {
 831             set auth 0
 832             get user string 1 8 \
 833                     abcdefghijklmnopqrustuvwxyz \
 834                     abcdefghijklmnopqrustuvwxyz-0123456789_
 835         }
 836         req-baduser {
 837             set auth 0
 838             get user rand 0 [expr {$mtu - 4}] 1
 839         }
 840         req-auth {
 841             get auth enum 0 31 0.5
 842             set user [depending-on remailck auth $mtu -4]
 843         }
 844         resp-auth {
 845             get auth hex 0 0xffff
 846             set modified 0
 847             set read 0
 848         }
 849         resp-ok {
 850             get mail choice-mult \
 851                     newmail 0.15 \
 852                     oldmail 0.15 \
 853                     nomail 0.20 \
 854                     times
 855             set auth 0
 856             switch -exact $mail {
 857                 newmail {
 858                     set modified 0
 859                     set read 1
 860                 }
 861                 oldmail {
 862                     set modified 1
 863                     set read 0
 864                 }
 865                 nomail {
 866                     set modified 0
 867                     set read 0
 868                 }
 869                 times {
 870                     get modified number 1 600
 871                     get read number 1 600
 872                 }
 873                 default { error "mail? $mail" }
 874             }
 875         }
 876         default { error "what? $what" }
 877     }
 878     switch -glob $what {
 879         req-* {
 880             assemble payload {
 881    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 882    |         Auth                                                  |
 883    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 884    |     User ...                                                  |
 885    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 886             }
 887         }
 888         resp-* {
 889             assemble payload {
 890    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 891    |         Auth                                                  |
 892    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 893    |         Modified                                              |
 894    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 895    |         Read                                                  |
 896    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 897             }
 898         }
 899         default { error "what?? $what" }
 900     }
 901     return $payload
 902 }
 903
 904 define remailck-auth 31 passwd {mtu} {
 905     get-for remailck-passwd
 906     get passwd string 6 8 \
 907             0123456789abcdefghijklmnopqrstuvxwyz \
 908             0123456789abcdefghijklmnopqrstuvxwyz
 909     return $passwd
 910 }
 911
 912 define udp-port 67 dhcpserv {mtu style} { return [dhcp $mtu] }
 913 define udp-port 68 dhcpclient {mtu style} { return [dhcp $mtu] }
 914 proc dhcp {mtu} {
 915     get-for dhcp
 916     get op enum 0 255 0.2
 917     get htype enum 0 255 0.2
 918     set hlen 6
 919     get hops number 0 255
 920     get xid hex32
 921     get secs number 0 300
 922     get flags hex 0 255
 923     get ciaddr v4addr
 924     get yiaddr v4addr
 925     get siaddr v4addr
 926     get giaddr v4addr
 927     set chaddr [random-bytes 16]
 928     get sname ntstring 0 64 \
 929             0123456789abcdefghijklmnopqrstuvwxyz \
 930             0123456789abcdefghijklmnopqrstuvwxyz.-+
 931     get file ntstring 0 128 / \
 932             0123456789abcdefghijklmnopqrstuvwxyz.-+/_
 933
 934     assemble dhcp {
 935    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 936    |     op        |   htype       |   hlen        |   hops        |
 937    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 938    |                            xid                                |
 939    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 940    |           secs                |           flags               |
 941    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 942    |                          ciaddr                               |
 943    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 944    |                          yiaddr                               |
 945    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 946    |                          siaddr                               |
 947    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 948    |                          giaddr                               |
 949    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 950     }
 951     append dhcp $chaddr $sname $file
 952
 953     return $dhcp
 954 }
 955 define dhcp-op 1 request {} {}
 956 define dhcp-op 2 reply {} {}
 957 define dhcp-htype 1 ethernet {} {}
 958
 959
 960 define ip-proto 6 tcp {mtu} {
 961     # RFC793
 962     get-for tcp
 963
 964     get source_port number 0 65535
 965     get dest_port number 0 65535
 966     get event choice-mult \
 967             connect 0.15 \
 968             accept 0.15 \
 969             close 0.15 \
 970             reset 0.15 \
 971             weird 0.15 \
 972             data
 973     set s 0
 974     set a 1
 975     set f 0
 976     set r 0
 977     switch -exact $event {
 978         connect { set s 1; set a 0 }
 979         accept { set s 1 }
 980         close { set f 1 }
 981         reset { set a 0; set r 1 }
 982         data { }
 983         weird {
 984             get s flag 0.5
 985             get a flag 0.5
 986             get f flag 0.5
 987             get r flag 0.5
 988         }
 989         default { error "event? $event" }
 990     }
 991     get seq hex32
 992     get ack hex32
 993     if {[choice-prob tcp-smallwindow 0.7]} {
 994         get window number 0 1
 995     } else {
 996         get window hex 0 0xffff
 997     }
 998     get p flag 0.5
 999     get u flag 0.3
1000     get urg hex 0 0xffff
1001
1002     set options {}
1003     get optmode choice-mult badopt 0.3 opt 0.6 noopt
1004     switch -exact $optmode {
1005         noopt { }
1006         badopt {
1007             get options rand 1 60 1
1008         }
1009         opt {
1010             while {[choice-prob tcp-opts-more 0.4]} {
1011                 get opt enum 1 255 0.5
1012                 if {$opt == 1} {
1013                     assemble option {
1014    +-+-+-+-+-+-+-+-+
1015    |  Opt          |
1016    +-+-+-+-+-+-+-+-+
1017                     }
1018                 } else {
1019                     set data [depending-on tcp opt 6 0]
1020                     set option_len 0
1021                     assemble option {
1022    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1023    |  Opt          | ? Option Len  |
1024    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1025    |      Data ...                 |
1026    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1027                     }
1028                     assembly-overwrite option option_len [packet-len $option]
1029                 }
1030                 append options $option
1031             }
1032         }
1033     }
1034
1035     if {[choice-prob reserved-nonzero 0.25]} {
1036         get reserved hex 0 0x3f
1037     } else {
1038         set reserved 0
1039     }
1040
1041     if {[packet-len $options] % 4 || [get optxpad choice 0.15]} {
1042         if {"$optmode" != "badopt"} { append options 00 }
1043         set padlen [expr {3 - ([packet-len $options] + 3) % 4}]
1044         append options [random-bytes $padlen]
1045     }
1046
1047     set d_off 0
1048     set checksum 0
1049     assemble packet {
1050    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1051    |          Source Port          |       Dest Port               |
1052    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1053    |                        Seq                                    |
1054    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1055    |                    Ack                                        |
1056    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1057    |? D Off| Reserved  |U|A|P|R|S|F|            Window             |
1058    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1059    |         ? Checksum            |         Urg                   |
1060    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1061    |                    Options     ...                            |
1062    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1063     }
1064
1065     set d_off [expr {([packet-len $packet]/4) & 0x0f}]
1066     assembly-overwrite packet d_off $d_off
1067
1068     if {!($s || $r) || [get unexpdata flag 0.2]} {
1069         get data rand 0 [expr {$mtu - [packet-len $packet]}] 1
1070         append packet $data
1071     }
1072     set tcp_length [packet-len $packet]
1073
1074     global ip_source ip_dest ip_proto
1075     assemble pseudo {
1076    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1077    |       IP Source                                               |
1078    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1079    |       IP Dest                                                 |
1080    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1081    |       0       | IP Proto      |        TCP length             |
1082    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1083     }
1084
1085     set csum [packet-csum-ip "$pseudo$packet"]
1086     if {[choice-prob tcp-badcsum 0.1]} {
1087         get csumerror hex 1 0xffff
1088         set csum [expr {$csum ^ $csumerror}]
1089     }
1090     assembly-overwrite packet checksum $csum
1091     return $packet
1092 }
1093
1094 define tcp-opt 2 mss {mdl} {
1095     get-for tcp-opt
1096     get mss hex 0 0xffff
1097     assemble od {
1098    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1099    |        MSS                    |
1100    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1101     }
1102     return $od
1103 }
1104
1105
1106 namespace eval PCap {
1107     namespace export pcap_open pcap_write pcap_write_raw pcap_close
1108
1109     proc pcap_open {fn} {
1110         variable fh
1111         catch { close $fh }
1112         set fh [open $fn w]
1113         fconfigure $fh -translation binary
1114     }
1115
1116     proc pcap_close {} {
1117         variable fh
1118         if {![info exists fh]} return
1119         close $fh
1120         unset fh
1121     }
1122
1123     proc pcap_write_raw {packet} {
1124         variable fh
1125         if {![info exists fh]} return
1126         puts -nonewline $fh [binary format H* $packet]
1127     }
1128
1129     proc pcap_write {valdeflist} {
1130         foreach {kind valvar} $valdeflist {
1131             if {![regexp {^([usx])([0-9]+)} $kind dummy mode bits]} {
1132                 error "unknown kind $kind for $valvar"
1133             }
1134             set value [uplevel 1 [list set $valvar]]
1135             if {$bits % 8} { error "bits must be mult 8 in $kind for $valvar" }
1136             if {"$mode" != "x"} {
1137                 set v {}
1138                 set ov $value
1139                 for {set i 0} {$i<$bits/8} {incr i} {
1140                     append v [format %02x [expr {$value & 0xff}]]
1141                     set value [expr {$value >> 8}]
1142                 }
1143                 if {$value != 0 && $value != -1} {
1144                     error "value $ov more than $bits bits (residue=$value)"
1145                 }
1146                 set value $v
1147             }
1148             if {[string length $value] != $bits/4} {
1149                 error "$valvar value $value wrong length, not $bits bits"
1150             }
1151             pcap_write_raw $value
1152         }
1153     }
1154 }
1155 namespace import PCap::*
1156
1157 proc emit {seed} {
1158     global getlog_log errorInfo mtu
1159
1160     get-for ip
1161     get-config source 127.0.0.1 v4addr
1162     get-config dest 127.0.0.1 v4addr
1163
1164     if {[catch {
1165         start_gen $seed
1166         set packet [gen_1_ip $mtu $source $dest]
1167         puts stdout "[format %6s $seed] $getlog_log\n       $packet"
1168     } emsg]} {
1169         puts stderr "\nERROR\n$seed\n\n$emsg\n\n$errorInfo\n\n"
1170         puts stdout "[format %6s $seed] error"
1171     } else {
1172         set ts_sec [clock seconds]
1173         set ts_usec 0
1174
1175         set llpkt [random-bytes 12] ;# ether addrs
1176         append llpkt 0800 ;# eth ip type
1177         append llpkt $packet
1178
1179         set len [packet-len "$llpkt"]
1180         pcap_write {
1181             u32 ts_sec
1182             u32 ts_usec
1183             u32 len
1184             u32 len
1185         }
1186         pcap_write_raw $llpkt
1187     }
1188 }
1189
1190
1191 proc nextarg {} {
1192     global argv
1193     if {![llength $argv]} { error "need another arg" }
1194     set a [lindex $argv 0]
1195     set argv [lrange $argv 1 end]
1196     return $a
1197 }
1198
1199 proc nextarg_num {} { return [expr {[nextarg] + 0}] }
1200
1201 set debug_level 0
1202 set mtu 576
1203 set upto {}
1204 set xseed {}
1205 while {[regexp {^\-\-} [lindex $argv 0]]} {
1206     set o [nextarg]
1207     switch -exact -- $o {
1208         --infinite { set upto -1 }
1209         --debug { set debug_level [nextarg_num] }
1210         --upto { set upto [nextarg_num] }
1211         --write { pcap_open [nextarg] }
1212         --mtu { set mtu [nextarg_num] }
1213         --xseed { set xseed [nextarg] }
1214         --source { set config/ip-source [nextarg] }
1215         --dest { set config/ip-dest [nextarg] }
1216         default { error "bad option $o" }
1217     }
1218 }
1219
1220 set magic d4c3b2a1
1221 set version_major 2
1222 set version_minor 4
1223 set thiszone 0
1224 set sigfigs 0
1225 set snaplen 131073
1226 set linktype 1
1227
1228 pcap_write {
1229     x32 magic
1230     u16 version_major
1231     u16 version_minor
1232     s32 thiszone
1233     s32 sigfigs
1234     s32 snaplen
1235     s32 linktype
1236 }
1237
1238 if {[llength $argv]} {
1239     foreach count $argv { emit "$xseed$count" }
1240 } else {
1241     if {![string length $upto]} { set upto 100 }
1242     for {set count 1} {$upto<0 || $count<=$upto} {incr count} {
1243         emit "$xseed$count"
1244     }
1245 }
1246
1247 pcap_close