make-probes.tcl

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