make-probes.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3
   4        package require profiler
   5        ::profiler::init
   6
   7
   8 set debug_level 1
   9
  10 proc debug {level str} {
  11     global debug_level
  12     if {$level < $debug_level} { puts stderr "debug\[$level] $str" }
  13 }
  14
  15 proc manyset {list args} {
  16     foreach val $list var $args {
  17         upvar 1 $var my
  18         set my $val
  19     }
  20 }
  21
  22
  23 proc start_gen {use_gen_counter} {
  24     global gen_counter rand_counter getlog_log rand_buf
  25     random-bytes-init $use_gen_counter
  26     set getlog_log {}
  27 }
  28
  29 proc packet-len {p} { expr {[string length $p]/2} }
  30
  31 proc packet-csum-ip {packet} {
  32     set cs 0
  33     append packet 00
  34     while {[regexp {^([0-9a-f][0-9a-f])(.*)$} $packet dummy this packet]} {
  35         incr cs 0x$this
  36     }
  37     return [expr {$cs & 0xffff}]
  38 }
  39
  40 proc packet-fromstring {s} {
  41     binary scan $s H* y
  42     return $y
  43 }
  44
  45 namespace eval Random-Bytes {
  46     namespace export random-bytes random-bytes-init
  47
  48     proc random-bytes-init {seed} {
  49         variable counter
  50         variable fh
  51         catch { set h $fh; unset fh; close $h }
  52         set counter 0
  53         set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
  54         fconfigure $fh -translation binary
  55     }
  56     proc random-bytes {n} {
  57         variable fh
  58         set x [read $fh $n]
  59         if {[string length $x] != $n} {
  60             set h $fh; unset fh; close $h
  61             error "openssl bf-ofb exited unexpectedly"
  62         }
  63         set y [packet-fromstring $x]
  64         return $y
  65     }
  66 }
  67
  68 namespace import Random-Bytes::*
  69
  70 proc choice-int {min max} {
  71     set rv 0x[random-bytes 3]
  72     return [expr {
  73         int( double($rv) / double(0x1000000) * double($max+1-$min) )
  74         + $min
  75     }]
  76 }
  77
  78 proc choice-prob {cv def} {
  79     set prob [config $cv $def]
  80     set rv 0x[random-bytes 3]
  81     return [expr {$rv < double($prob)*0x1000000}]
  82 }
  83
  84 proc choice-mult {args} {
  85     if {!([llength $args] % 2)} { error "choice-mult must have default" }
  86     set x 0x[random-bytes 3]
  87     set x [expr { double($x) / double(0x1000000) }]
  88     set cump 0.0
  89     set def [lindex $args end]
  90     set args [lreplace $args end end]
  91     foreach {val p} $args {
  92         set cump [expr {$cump + double($p)}]
  93         if {$x < $cump} { return $val }
  94     }
  95     return $def
  96 }
  97
  98 proc getlog {msg} {
  99     upvar #0 getlog_log log
 100     append log " $msg"
 101     debug 2 "getlog $msg"
 102 }
 103
 104 proc config {cv def} {
 105     upvar #0 config/$cv v
 106     if {[info exists v]} { return $v }
 107     return $def
 108 }
 109
 110
 111 proc define {enum val name argnames body} {
 112     upvar #0 enum/val2name/$enum v2n
 113     upvar #0 enum/name2val/$enum n2v
 114     set v2n($val) $name
 115     set n2v($name) $val
 116     proc enum/val/$enum/$val $argnames $body
 117 }
 118
 119 proc depending-on {scope enum_and_var mtu mtuadjust args} {
 120     upvar 1 $enum_and_var val
 121     set mtu [expr {$mtu + $mtuadjust}]
 122     set procname enum/val/$scope-$enum_and_var/[format %d $val]
 123     if {[choice-prob $enum_and_var-unstruct 0.1] ||
 124             [catch { info body $procname }]} {
 125         # half the time random
 126         getlog (junk)
 127         get-for $scope-fill
 128         get data rand 0 $mtu
 129         return $data
 130     } else {
 131         uplevel 1 [list $procname] $mtu $args
 132     }
 133 }
 134
 135
 136 proc get-for {scope} {
 137     upvar 1 get/scope ns
 138     set ns $scope
 139 }
 140
 141 proc get {variable kind args} {
 142     upvar 1 get/scope scope
 143     upvar 1 $variable var
 144     set var [eval [list get/$kind $scope $variable] $args]
 145 }
 146
 147 proc get-config/number {val min max} { return $val }
 148 proc get-config/v4addr {val} {
 149     if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
 150         error "bad v4addr ?$val?"
 151     }
 152     return [format 0x%02x%02x%02x%02x $a $b $c $d]
 153 }
 154
 155 proc get-config {variable def kind args} {
 156     # args currently ignored
 157     upvar 1 get/scope scope
 158     upvar 1 $variable var
 159     set val [config $scope-$variable $def]
 160     set var [eval [list get-config/$kind $val] $args]
 161 }
 162
 163 proc get-enum-got {s v rv} {
 164     upvar #0 enum/val2name/$s-$v v2n
 165     if {[info exists v2n($rv)]} {
 166         getlog "$v=$v2n($rv)\[$rv]"
 167     } else {
 168         getlog "$v=$rv"
 169     }
 170     return $rv
 171 }
 172
 173 proc get/enum-rand {s v min max} {
 174     set rv [choice-int $min $max]
 175     return [get-enum-got $s $v $rv]
 176 }
 177
 178 proc get/enum-def {s v} {
 179     upvar #0 enum/val2name/$s-$v v2n
 180     set rv [choice-int 1 [array size v2n]]
 181     set rv [lindex [array names v2n] [expr {$rv-1}]]
 182     return [get-enum-got $s $v $rv]
 183 }
 184
 185 proc get/enum {s v min max prand} {
 186     get-for $s-$v
 187     get any choice $prand
 188     if {$any} {
 189         return [get/enum-rand $s $v $min $max]
 190     } else {
 191         return [get/enum-def $s $v]
 192     }
 193 }
 194
 195 proc get/number {s v min max} {
 196     set rv [choice-int $min $max]
 197     getlog "$v=$rv"
 198     return $rv
 199 }
 200
 201 proc get/hex {s v min max} {
 202     set rv [choice-int $min $max]
 203     getlog [format %s=0x%x $v $rv]
 204     return $rv
 205 }
 206
 207 proc get/flag {s v defprob} {
 208     set rv [choice-prob $s-$v $defprob]
 209     if {$rv} { getlog "$v" } else { getlog "!$v" }
 210     return $rv
 211 }
 212
 213 proc get/choice {s v defprob} {
 214     set rv [choice-prob $s-$v $defprob]
 215     if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
 216     return $rv
 217 }
 218
 219 proc get/rand {s v minlen maxlen} {
 220     get-for $s-$v
 221     get l number $minlen $maxlen
 222     return [random-bytes $l]
 223 }
 224
 225 proc get/ip-timestamp {s v} {
 226     set rv [expr {[clock seconds] | 0x80000000}]
 227     getlog "$v=[format %x $rv]"
 228     return $rv
 229 }
 230
 231 proc get/v4addr {s v} {
 232     set rv 0x
 233     set p {}
 234     set d {}
 235     for {set i 0} {$i<4} {incr i} {
 236         set b [random-bytes 1]
 237         append rv $b
 238         append p $d [format %d 0x$b]
 239         set d .
 240     }
 241     getlog "$v=$p"
 242     return $rv
 243 }
 244
 245 proc get/choice-mult {s v args} {
 246     set rv [eval choice-mult $args]
 247     getlog "($rv)"
 248     return $rv
 249 }
 250
 251 proc get/string {s v minlen maxlen first rest} {
 252     set o {}
 253     set now $first
 254     for {set l [choice-int $minlen $maxlen]} {$l>0} {incr l -1} {
 255         set cn [choice-int 0 [expr {[string length $now]-1}]]
 256         append o [string index $now $cn]
 257         set now $rest
 258     }
 259     getlog "$v=\"$o\""
 260     return [packet-fromstring $o]
 261 }
 262
 263
 264 namespace eval Assembler {
 265     namespace export assemble assembly-overwrite
 266
 267     proc assemble {outvarname format} {
 268         # format should look like those RFC diagrams.
 269         # +-+-+ stuff and good formatting is mandatory.
 270         # Tabs are forbidden.
 271         #
 272         # Field names are converted to lowercase; internal spaces
 273         # are replaced with _.  They are then assumed to be
 274         # variable names in the caller's scope.  The packet is
 275         # assembled from those values (which must all be set)
 276         # and stored in $varname in the caller's scope.
 277         #
 278         # Variables ?_whatever will be *set* with the location of the
 279         # field in the string (in internal format); the corresponding
 280         # `whatever' (with the ?_ stripped) will be read when assembling.
 281         #
 282         # Field name `0' means set the field to zero.
 283
 284         variable cache
 285         upvar 1 $outvarname out
 286         if {[catch { set parsed $cache($format) }]} {
 287             set parsed [parse $format]
 288             set cache($format) $parsed
 289         }
 290
 291         manyset $parsed outbytes lout
 292         set out [string repeat 00 $outbytes]
 293         foreach {location varname locvarname} $lout {
 294             if {"$varname" == "0"} {
 295                 set value 0
 296             } else {
 297                 set value [uplevel 1 [list set $varname]]
 298             }
 299             if {[string length $locvarname]} {
 300                 upvar 1 $locvarname lv
 301                 set lv $location
 302             }
 303             assembly-overwrite out $location $value
 304         }
 305     }
 306
 307     proc parse {format} {
 308         set lno 0
 309         set outbytes 0
 310         debug 7 "ASSEMBLY $format"
 311         foreach l [split $format "\n"] {
 312             incr lno
 313             if {[regexp -nocase {^ *\| +\| *$} $l]} {
 314                 if {![info exists wordbits]} {
 315                     error "vspace not in data @$lno\n?$l?"
 316                 }
 317                 incr words
 318             } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
 319                 if {[info exists words]} {
 320                     error "data without delimline @$lno\n?$l?"
 321                 }
 322                 set words 1
 323                 set cue $l
 324             } elseif {[regexp {^ *[-+]+ *$} $l]} {
 325                 set wordbits 0
 326                 set newlineform {}
 327                 while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
 328                     set atpos([string length $before]) $wordbits
 329                     incr wordbits
 330                     set l "$before=$after"
 331                     append newlineform "@[string length $before]:$wordbits "
 332                 }
 333                 incr wordbits -1
 334                 append newlineform $wordbits
 335                 if {[info exists lineform]} {
 336                     if {"$newlineform" != "$lineform"} {
 337  error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
 338                     }
 339                     if {![info exists words] || $words<0} {
 340                         error "consecutive delimlines @$lno\n?$l?"
 341                     }
 342                     incr outbytes [expr {$words*$wordbits/8}]
 343                     set l $cue
 344                     while {[regexp -nocase \
 345                             {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
 346                             $l dummy before midpart after]} {
 347                         debug 7 "RWORKG ?$l?"
 348                         set varname [string tolower [string trim $midpart]]
 349                         set varname [string map {{ } _} $varname]
 350                         set p1 [string length $before]
 351                         set p2 [expr {
 352                             [string length $before] +
 353                             [string length $midpart] + 1
 354                         }]
 355                         if {![info exists atpos($p1)] ||
 356                             ![info exists atpos($p2)]} {
 357  error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
 358                         }
 359                         set bit1 [expr {
 360                             $outbytes*8
 361                             - $words*$wordbits
 362                             + $atpos($p1)
 363                         }]
 364                         set bitlen [expr {
 365                             $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
 366                         }]
 367                         set location [list $bit1 $bitlen $varname]
 368                         if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
 369                             debug 7 "LOCATING $varname $location"
 370                             set locvarname $varname
 371                             set varname $realvarname
 372                         } else {
 373                             set locvarname {}
 374                         }
 375                         lappend lout $location $varname $locvarname
 376                         set l "$before="
 377                         append l [string repeat = [string length $midpart]]
 378                         append l |$after
 379                     }
 380                     debug 7 "REMAIN ?$l?"
 381                 } else {
 382                     if {$wordbits % 8 || $wordbits >32} {
 383                         error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 384                     }
 385                     set lineform $newlineform
 386                 }
 387                 catch { unset words }
 388             } elseif {[regexp {^ *$} $l]} {
 389             } else {
 390                 error "huh? @$lno ?$l?"
 391             }
 392         }
 393         debug 7 "ASSEMBLY\n$outbytes\n$lout\n"
 394         return [list $outbytes $lout]
 395     }
 396
 397     proc assembly-overwrite {outvarname location value} {
 398         upvar 1 $outvarname out
 399         manyset $location bit1 bitlen diag
 400  debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
 401         if {$bitlen < 32 && $value >= (1<<$bitlen)} {
 402             error "$diag $value >= 2**$bitlen"
 403         }
 404         if {!($bit1 % 8) && !($bitlen % 8)} {
 405             set char0no [expr {$bit1/4}]
 406             set charlen [expr {$bitlen/4}]
 407             set chareno [expr {$char0no + $charlen -1}]
 408             set repl [format %0${charlen}x $value]
 409             set out [string replace $out $char0no $chareno $repl]
 410         } else {
 411             while {$bitlen > 0} {
 412                 set byteno [expr {$bit1 / 8}]
 413                 set char0no [expr {$byteno*2}]
 414                 set char1no [expr {$char0no+1}]
 415                 set bytebit [expr {128>>($bit1 % 8)}]
 416                 set byte 0x[string range $out $char0no $char1no]
 417                 debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
 418                 set byte [expr {
 419                     ($value & (1<<($bitlen-1)))
 420                     ? ($byte | $bytebit)
 421                     : ($byte & ~$bytebit)
 422                 }]
 423                 set out [string replace $out $char0no $char1no \
 424                         [format %02x $byte]]
 425  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
 426                 incr bitlen -1
 427                 incr bit1
 428             }
 429         }
 430     }
 431 }
 432 namespace import Assembler::*
 433
 434 proc gen_1_ip {mtu} {
 435     # RFC791
 436     upvar #0 ip_proto proto
 437     upvar #0 ip_source source
 438     upvar #0 ip_dest dest
 439     get-for ip
 440     set version 4
 441     get tos hex 0x00 0xff
 442     get id hex 0x0000 0xffff
 443     get df flag 0.5
 444     if {$df} {
 445         set mf 0
 446         set frag 0
 447     } {
 448         get mf flag 0.5
 449         get frag number 0 0x1fff
 450     }
 451     get-config ttl 255 number 0 255
 452     get proto enum 1 255 0.05
 453     get-config source 127.0.0.1 v4addr
 454     get-config dest 127.0.0.1 v4addr
 455     # we don't do any IP options
 456     set ihl 5
 457     set body [depending-on ip proto $mtu [expr {-4*$ihl}]]
 458     set total_length [expr {$ihl + [packet-len $body]}]
 459     set header_checksum 0
 460     set flags [expr {$df*2 + $mf}]
 461     assemble ip {
 462    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 463    |Version|  IHL  |TOS            |         Total Length          |
 464    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 465    |         Id                    |Flags|      Frag               |
 466    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 467    |  TTL          |    Proto      |      ? Header Checksum        |
 468    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 469    |                       Source                                  |
 470    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 471    |                    Dest                                       |
 472    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 473     }
 474     assembly-overwrite ip ${?_header_checksum} [packet-csum-ip $ip]
 475     append ip $body
 476     return $ip
 477 }
 478
 479 define ip-proto 1 icmp {mtu} {
 480     # RFC792
 481     get-for icmp
 482     get type enum 0 255 0.2
 483     manyset [depending-on icmp type $mtu -4] body code
 484     if {![string length $code]} { get code number 0 255 }
 485     set checksum 0
 486     assemble icmp {
 487    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 488    |     Type      |     Code      |        ? Checksum             |
 489    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 490     }
 491     append icmp $body
 492     assembly-overwrite icmp ${?_checksum} [packet-csum-ip $icmp]
 493     return $icmp
 494 }
 495
 496 proc define-icmp-type-vanilla {num name} {
 497     define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
 498 }
 499 proc icmp-vanilla {mbl typename} {
 500     get-for icmp-$typename
 501     get code enum 0 255 0.4
 502     get body rand 0 $mbl
 503     return [list $body $code]
 504 }
 505
 506 define-icmp-type-vanilla 3 unreach
 507 define icmp-unreach-code 0 net {} {}
 508 define icmp-unreach-code 1 host {} {}
 509 define icmp-unreach-code 2 proto {} {}
 510 define icmp-unreach-code 3 port {} {}
 511 define icmp-unreach-code 4 fragneeded {} {}
 512 define icmp-unreach-code 5 sourceroutefail {} {}
 513
 514 define-icmp-type-vanilla 11 timeout
 515 define icmp-timeout-code 0 intransit {} {}
 516 define icmp-timeout-code 1 fragment {} {}
 517
 518 define-icmp-type-vanilla 12 parameters
 519 define icmp-parameters-code 0 seepointer {} {}
 520
 521 define-icmp-type-vanilla 4 sourcequench
 522 define icmp-sourcequench-code 0 quench {} {}
 523
 524 define icmp-type 5 redirect {mbl} {
 525     get-for icmp-redirect
 526     get code enum 0 255 0.4
 527     get gateway v4addr
 528     assemble body {
 529    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 530    |                 Gateway                                       |
 531    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 532     }
 533     get data rand 0 [expr {$mbl-4}]
 534     append body $data
 535     return [list $body $code]
 536 }
 537
 538 define icmp-redirect-code 0 net {} {}
 539 define icmp-redirect-code 1 host {} {}
 540 define icmp-redirect-code 2 net+tos {} {}
 541 define icmp-redirect-code 3 host+tos {} {}
 542
 543 define icmp-type 8 ping {mbl} { icmp-echo $mbl }
 544 define icmp-type 0 pong {mbl} { icmp-echo $mbl }
 545 proc icmp-echo {mbl} {
 546     get-for icmp-echo
 547     get code enum 0 255 0.4
 548     get id hex 0 0xffff
 549     get seq hex 0 0xffff
 550     assemble body {
 551    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 552    |       Id                      |        Seq                    |
 553    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 554     }
 555     get data rand 0 [expr {$mbl-8}]
 556     append body $data
 557     return [list $body $code]
 558 }
 559 define icmp-echo-code 0 echo {} {}
 560
 561 define icmp-type 13 timestamp {mbl} { icmp-timestamp }
 562 define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
 563 proc icmp-timestamp {} {
 564     get-for icmp-timestamp
 565     get code enum 0 255 0.4
 566     get id hex 0 0xffff
 567     get seq hex 0 0xffff
 568     get originate ip-timestamp
 569     get receive ip-timestamp
 570     get transmit ip-timestamp
 571     assemble body {
 572    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 573    |           Id                  |        Seq                    |
 574    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 575    |     Originate                                                 |
 576    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 577    |     Receive                                                   |
 578    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 579    |     Transmit                                                  |
 580    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 581     }
 582     return [list $body $code]
 583 }
 584 define icmp-timestamp-code 0 timestamp {} {}
 585
 586 define icmp-type 15 inforequest {mbl} { icmp-inforeq }
 587 define icmp-type 16 inforeply {mbl} { icmp-inforeq }
 588 proc icmp-inforeq {} {
 589     get-for icmp-inforeq
 590     get code enum 0 255 0.4
 591     get id hex 0 0xffff
 592     get seq hex 0 0xffff
 593     assemble body {
 594    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 595    |           Id                  |        Seq                    |
 596    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 597     }
 598     return [list $body $code]
 599 }
 600 define icmp-inforeq-code 0 timestamp {} {}
 601
 602 # MAYADD ICMP traceroute RFC1393
 603 # MAYADD ICMP router discovery RFC1256
 604
 605 proc port_pair_data {scope mtu mtuadjust} {
 606     get-for $scope
 607
 608     get style choice-mult \
 609             request 0.24 \
 610             reply 0.24 \
 611             random 0.16 \
 612             servers
 613
 614     if {"$style" != "random"} {
 615         get port enum-def
 616         set def_port $port
 617     }
 618     if {"$style" != "servers"} {
 619         get port enum-rand 0 0xffff
 620         set rand_port $port
 621     }
 622     switch -exact $style {
 623         random  { set source_port $rand_port; set dest_port $rand_port }
 624         request { set source_port $rand_port; set dest_port $def_port }
 625         reply   { set source_port $def_port;  set dest_port $rand_port }
 626         servers { set source_port $def_port;  set dest_port $def_port }
 627     }
 628     if {"$style" != "random"} {
 629         set port $def_port
 630         set data [depending-on $scope port $mtu $mtuadjust $style]
 631     } else {
 632         get data rand 0 [expr {$mtu + $mtuadjust}]
 633     }
 634     return [list $source_port $dest_port $data]
 635 }
 636
 637 define ip-proto 17 udp {mtu} {
 638     get-for udp
 639     get checksum choice-mult \
 640             checksum_bad 0.20 \
 641             checksum_none 0.20 \
 642             checksum_good
 643     manyset [port_pair_data udp $mtu 8] source_port dest_port data
 644     set length [packet-len $data]
 645     set checksum 0
 646     assemble udp {
 647    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 648    |       Source Port             |        Dest Port              |
 649    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 650    |         Length                |      ? Checksum               |
 651    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 652     }
 653     append udp $data
 654     if {"$checksum" != "none"} {
 655         set csum [packet-csum-ip $udp]
 656         if {!$csum} { set csum 0xffff }
 657         if {"$checksum" == "bad"} {
 658             get error hex 1 0xffff
 659             set csum [expr {$csum ^ $error}]
 660         }
 661     } else {
 662         set csum 0
 663     }
 664     assembly-overwrite udp ${?_checksum} $csum
 665 }
 666
 667 define udp-port 50 remailck {mtu style} {
 668     get-for remailck
 669     if {"$style" == "request"} {
 670         get what choice-mult \
 671                 req-baduser 0.15 \
 672                 req-auth 0.15 \
 673                 resp-ok 0.15 \
 674                 resp-auth 0.15 \
 675                 req-user
 676     } else {
 677         get what choice-mult \
 678                 req-baduser 0.15 \
 679                 req-auth 0.15 \
 680                 resp-auth 0.15 \
 681                 req-user 0.15 \
 682                 resp-ok
 683     }
 684     switch -exact $what {
 685         req-user {
 686             set auth 0
 687             get user string 1 8 \
 688                     abcdefghijklmnopqrustuvwxyz \
 689                     abcdefghijklmnopqrustuvwxyz-0123456789_
 690         }
 691         req-baduser {
 692             set auth 0
 693             get user rand 0 [expr {$mtu - 4}]
 694         }
 695         req-auth {
 696             get auth enum 0 31 0.5
 697             set user [depending-on remailck auth $mtu -4]
 698         }
 699         resp-auth {
 700             get auth hex 0 0xffff
 701             set modified 0
 702             set read 0
 703         }
 704         resp-ok {
 705             get mail choice-mult \
 706                     newmail 0.15 \
 707                     oldmail 0.15 \
 708                     nomail 0.20 \
 709                     times
 710             set auth 0
 711             switch -exact $mail {
 712                 newmail {
 713                     set modified 0
 714                     set read 1
 715                 }
 716                 oldmail {
 717                     set modified 1
 718                     set read 0
 719                 }
 720                 nomail {
 721                     set modified 0
 722                     set read 0
 723                 }
 724                 times {
 725                     get modified number 1 600
 726                     get read number 1 600
 727                 }
 728                 default { error "mail? $mail" }
 729             }
 730         }
 731         default { error "what? $what" }
 732     }
 733     switch -glob $what {
 734         req-* {
 735             assemble packet {
 736    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 737    |         Auth                                                  |
 738    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 739             }
 740             append packet $user
 741         }
 742         resp-* {
 743             assemble packet {
 744    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 745    |         Auth                                                  |
 746    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 747    |         Modified                                              |
 748    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 749    |         Read                                                  |
 750    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 751             }
 752         }
 753         default { error "what?? $what" }
 754     }
 755     return $packet
 756 }
 757
 758 define remailck-auth 31 passwd {mtu} {
 759     get-for remailck-passwd
 760     get passwd string 6 8 \
 761             0123456789abcdefghijklmnopqrstuvxwyz \
 762             0123456789abcdefghijklmnopqrstuvxwyz
 763     return $passwd
 764 }
 765
 766
 767 proc emit {count} {
 768     global getlog_log errorInfo
 769     if {[catch {
 770         start_gen $count
 771         set packet [gen_1_ip 576]
 772         puts stdout "[format %06d $count] $getlog_log\n       $packet"
 773     } emsg]} {
 774         puts stderr "\nERROR\n$count\n\n$emsg\n\n$errorInfo\n\n"
 775         puts stdout "[format %06d $count] error"
 776     }
 777 }
 778
 779 if {![llength $argv]} {
 780     for {set count 1} {$count < 100} {incr count} { emit $count }
 781 } elseif {"$argv" == "--infinite"} {
 782     set count 1
 783     while 1 { emit $count; incr count }
 784 } else {
 785     foreach count $argv { emit $count }
 786 }
 787
 788
 789 puts [::profiler::dump]
 790
 791 puts ---------------------IWJ
 792
 793 puts [::profiler::print]
 794
 795 puts ---------------------IWJ
 796
 797 foreach i [::profiler::sortFunctions totalRuntime] {
 798     manyset $i f v
 799     puts [::profiler::print $f]
 800 }