SecuritySNACCRuntime/tcl-asn/beredit

   1 #!/bin/sh
   2 # the next line restarts using wish \
   3 exec asnwish "$0" "$@"
   4
   5 proc err {msg} {
   6     tk_dialog .err Error $msg {} 0 Damn
   7 }
   8
   9 proc ref {desc} {
  10     set res [lindex $desc 0]
  11     if {$res==""} {
  12         set res [lindex $desc 1]
  13         if {$res=="TYPEREF"} {
  14             set res [lindex [lindex $desc 4] 1]
  15         }
  16     }
  17     return $res
  18 }
  19
  20 proc complete {ntp} {
  21     global pdu
  22     upvar $ntp tp
  23     set tp [string trimright "$pdu $tp"]
  24 }
  25
  26 proc newenc {tp r toggle} {
  27     global asnenc
  28     set idx $tp
  29     if {$toggle} {
  30         set cur [lindex [array get asnenc $idx] 1]
  31         set pr [lsearch -exact $cur $r]
  32         if {$pr==-1} {
  33             lappend cur $r
  34         } else {
  35             set cur [lreplace $cur $pr $pr]
  36         }
  37         set asnenc($idx) $cur
  38     } else {
  39         set asnenc($idx) $r
  40     }
  41     fillcomposer
  42 }
  43
  44 proc selpress {y} {
  45     global tag
  46     set i [.selector.l nearest $y]
  47     if {$i==0} return
  48     set tpval [.selector.l get $i]
  49     if {$tag(selector)=="CHOICE"} {
  50         newenc [lindex $tpval 0] [lindex $tpval 1] 0
  51     } else {
  52         newenc [lindex $tpval 0] [lindex $tpval 1] 1
  53     }
  54 }
  55
  56 proc comppress {y} {
  57     global table tag
  58     set i [.composer.l nearest $y]
  59     set tpval [.composer.l get $i]
  60     set tp [lindex $tpval 0]
  61     set val [lindex $tpval 1]
  62     set typetoask $tp
  63     set td [$table type -followref $typetoask]
  64     set t [lindex $td 1]
  65     switch $t {
  66         CHOICE {
  67             set tag(selector) $t
  68             .selector.l delete 0 end
  69             .selector.l insert end "$tp is a CHOICE of:"
  70             foreach {subtypedesc req} [lindex $td 4] {
  71                 set r [ref $subtypedesc]
  72                 .selector.l insert end [list $tp $r]
  73             }
  74             wm withdraw .insertor
  75             wm deiconify .selector
  76             raise .selector
  77         }
  78         SEQUENCE {
  79             set tag(selector) $t
  80             .selector.l delete 0 end
  81             .selector.l insert end "In SEQUENCE $tp, the following are OPTIONAL:"
  82             foreach {subtypedesc req} [lindex $td 4] {
  83                 if {!$req} {
  84                     set r [ref $subtypedesc]
  85                     .selector.l insert end [list $tp $r]
  86                 }
  87             }
  88             wm withdraw .insertor
  89             wm deiconify .selector
  90             raise .selector
  91         }
  92         default {
  93             if {$t=="SEQUENCE OF"} {
  94                 set text "Size of SEQUENCE OF $tp:"
  95             } else {
  96                 set text "New value of $tp:"
  97             }
  98             set tag(insertor) $tp
  99             .insertor.l configure -text $text
 100             .insertor.e delete 0 end
 101             .insertor.e insert 0 $val
 102             wm withdraw .selector
 103             wm deiconify .insertor
 104             raise .insertor
 105         }
 106     }
 107 }
 108
 109 proc inspress {} {
 110     global tag
 111     newenc $tag(insertor) [.insertor.e get] 0
 112 }
 113
 114 proc fillcomposer {} {
 115     global table pdu
 116     set fraction 0.0
 117     if [winfo exists .composer.l] {
 118         set fraction [lindex [.composer.l yview] 0]
 119         .composer.l delete 0 end
 120     } else {
 121         frame .composer
 122         pack .composer -fill both -expand 1
 123         listbox .composer.l -yscrollcommand ".composer.v set"
 124         scrollbar .composer.v -orient vertical -command ".composer.l yview"
 125         pack .composer.v -fill y -side right
 126         pack .composer.l -expand yes -fill both
 127         bind .composer.l <ButtonPress-1> {comppress %y}
 128         toplevel .selector
 129         listbox .selector.l -yscrollcommand ".selector.v set"
 130         scrollbar .selector.v -orient vertical -command ".selector.l yview"
 131         pack .selector.v -fill y -side right
 132         pack .selector.l -expand yes -fill both
 133         bind .selector.l <ButtonPress-1> {selpress %y}
 134         wm protocol .selector WM_DELETE_WINDOW {wm withdraw .selector}
 135         wm title .selector "Snacc ASN.1 data item selection"
 136         toplevel .insertor
 137         label .insertor.l
 138         entry .insertor.e
 139         pack .insertor.l -fill x -expand yes -side top
 140         pack .insertor.e -fill x -expand yes -side bottom
 141         bind .insertor.e <KeyPress-Return> {inspress}
 142         wm protocol .insertor WM_DELETE_WINDOW {wm withdraw .insertor}
 143         wm title .insertor "Snacc ASN.1 data item modification"
 144     }
 145     wm withdraw .selector
 146     wm withdraw .insertor
 147     set null [open "/dev/null" w]
 148     $table encode $null $pdu "encodevalcompose $null"
 149     close $null
 150     .composer.l yview moveto $fraction
 151     wm deiconify .
 152     raise .
 153 }
 154
 155 proc decodetype {tp val} {
 156     complete tp
 157     if {$val==-1} {
 158         set l [expr [llength $tp]-1]
 159         set final [lindex $tp $l]
 160         set addto [lrange $tp 0 [expr $l-1]]
 161         global table asnenc
 162         set td [$table type -followref $addto]
 163         if {[lindex $td 1]=="SEQUENCE"} {
 164             if [catch {set asnenc($addto)}] {
 165                 set asnenc($addto) ""
 166             }
 167             foreach {elem req} [lindex $td 4] {
 168                 if {[lindex $elem 0]==$final} {
 169                     if {!$req} {
 170                         lappend asnenc($addto) $final
 171                     }
 172                     break
 173                 }
 174             }
 175         } else {
 176             set asnenc($addto) $final
 177         }
 178     }
 179 }
 180
 181 proc decodeval {chan tp val} {
 182     decodetype $tp -1
 183     global asnenc table
 184     complete tp
 185     set typ [$table type -followref $tp]
 186     if {[lindex $typ 1]=="BIT STRING"} {
 187         set namespecs [lindex $typ 3]
 188         set bitno 0
 189         foreach bit [split $val ""] {
 190             set idx [lsearch $namespecs "$bitno *"]
 191             if {$idx>=0 && $bit} {
 192                 lappend val "[lindex {! {}} $bit][lindex [lindex $namespecs $idx] 1]($bitno)"
 193             }
 194             incr bitno
 195         }
 196     } elseif {[lindex $typ 1]=="ENUMERATED"} {
 197         set namespecs [lindex $typ 3]
 198         set idx [lsearch $namespecs "$val *"]
 199         if {$idx>=0} {
 200             lappend val "[lindex [lindex $namespecs $idx] 1]"
 201         }
 202     }
 203     set asnenc($tp) $val
 204 }
 205
 206 proc encodevalcompose {chan tp} {
 207     global asnenc
 208     complete tp
 209     if [catch {set val $asnenc($tp)}] {
 210         set val {}
 211     }
 212     .composer.l insert end [list $tp $val]
 213     return $val
 214 }
 215
 216 proc encodeval {chan tp val} {
 217     global table
 218     set prefix -
 219     set val [subst -nobackslashes $val]
 220     set typ [$table type -followref $tp]
 221     if {[lindex $typ 1]=="OCTET STRING"} {
 222         set fromto [lindex $typ 2]
 223         set from [lindex $fromto 0]
 224         set to [lindex $fromto 1]
 225         if {$to==""} {
 226             set to $from
 227         }
 228         regsub -all {[^\\]} $val {} slashes
 229         set len [expr [string length $val] - [string length $slashes] * 3]
 230         if {$from!={} && $from>$len} {
 231             set val [format "%$prefix[expr $from]s" $val]
 232         } elseif {$to!={} && $to<$len} {
 233             err [list encodeval: value $val for $tp >$to]
 234             while {$to<$len} {
 235                 set last [string last \\ $val]
 236                 if {$last==-1 || $last<[string length $val]-4} {
 237                     set val [string range $val 0 [expr [string length $val] - 2]]
 238                 } else {
 239                     set val [string range $val 0 [expr $last - 1]]
 240                 }
 241                 regsub -all {[^\\]} $val {} slashes
 242                 set len [expr [string length $val] - [string length $slashes] * 3]
 243             }
 244         }
 245     } elseif {[lindex $typ 1]=="BIT STRING"} {
 246         set namespecs [lindex $typ 3]
 247         if {[regexp {^[01]+$} [lindex $val 0]]} {
 248             set val [split [lindex $val 0] ""]
 249         } else {
 250             set names $val
 251             set val {}
 252             foreach name $names {
 253                 if {[regsub {([a-zA-Z_][a-zA-Z0-9_]*)?\(([0-9]+)\)} $name {\2} bitno]!=1} {
 254                     set idx [lsearch -regexp $namespecs "^\[0-9\]+ $name$"]
 255                     if {$idx<0} {
 256                         err "Bit $name of $tp not in $namespecs"
 257                         continue
 258                     }
 259                     set bitno [lindex [lindex $namespecs $idx] 0]
 260                 }
 261                 while {[llength $val]<=$bitno} {
 262                     lappend val 0
 263                 }
 264                 set val [lreplace $val $bitno $bitno 1]
 265             }
 266         }
 267         proc namespeccmp {a b} {return [expr [lindex $a 0] - [lindex $b 0]]}
 268         set sorted [lsort -command namespeccmp -decreasing $namespecs]
 269         set bitno [lindex [lindex $sorted 0] 0]
 270         while {[llength $val]<=$bitno} {
 271             lappend val 0
 272         }
 273         set val [join $val ""]
 274     } elseif {[lindex $typ 1]=="ENUMERATED"} {
 275         set namespecs [lindex $typ 3]
 276         if {![regexp {^[0-9]*$} [lindex $val 0]]} {
 277             set idx [lsearch -regexp $namespecs "^\[0-9\]+ $val$"]
 278             if {$idx<0} {
 279                 err "Named value $val of $tp not in $namespecs"
 280             } else {
 281                 set val [lindex [lindex $namespecs $idx] 0]
 282             }
 283         }
 284     }
 285     return $val
 286 }
 287
 288 proc encodeasnenc {chan tp} {
 289     global asnenc pdu
 290     complete tp
 291     if [catch {set val $asnenc($tp)}] {
 292         set val {}
 293     }
 294     return [encodeval $chan $tp $val]
 295 }
 296
 297 wm title . "Snacc ASN.1 message editor"
 298 wm geometry . 400x300
 299 frame .mbar -relief raised
 300 pack .mbar -side top -fill x
 301
 302 menubutton .mbar.file -text Message -menu .mbar.file.menu
 303 pack .mbar.file -side left
 304
 305 menu .mbar.file.menu
 306 .mbar.file.menu add command -label "Open ..." -command {openfile}
 307 .mbar.file.menu add command -label "Save As ..." -command {savefile}
 308 .mbar.file.menu add command -label "Quit" -command {quit}
 309 wm protocol . WM_DELETE_WINDOW {quit}
 310
 311 proc readfile {fn} {
 312     if {$fn==""} return
 313     global table pdu asnenc
 314     catch {unset asnenc}
 315     set chan [open $fn r]
 316     fconfigure $chan -translation binary
 317     set bytes [$table decode $chan $pdu "decodeval $chan" decodetype]
 318     close $chan
 319     fillcomposer
 320 }
 321
 322 proc openfile {} {
 323     readfile [tk_getOpenFile -defaultextension .ber -filetypes {{{ASN.1 data} {.ber .bin .out .tt}} {{All files} {.*}}}]
 324 }
 325
 326 proc savefile {} {
 327     set fn [tk_getSaveFile -defaultextension .ber -filetypes {{{ASN.1 data} {.ber .bin .out .tt}} {{All files} {.*}}}]
 328     if {$fn==""} return
 329     global table pdu
 330     set chan [open $fn w]
 331     $table encode $chan $pdu "encodeasnenc $chan"
 332     close $chan
 333 }
 334
 335 proc quit {} {
 336     global done
 337     set done 1
 338 }
 339
 340 set asnfile [lindex $argv 0]
 341 if {$asnfile==""} {
 342     puts stderr "Usage: $argv0 <table-file> ?<ber-file>?"
 343     puts stderr ""
 344     puts stderr "This program is a simple editor for ASN.1 messages"
 345     puts stderr "encoded using the Basic Encoding Rules (BER). It requires"
 346     puts stderr "the grammar specification, in binary format as generated"
 347     puts stderr "by \"snacc -T\", as the initial argument on the command line."
 348     puts stderr ""
 349     puts stderr "The purpose of this program is to demonstrate the usage of"
 350     puts stderr "the new Tcl/Tk command \"asn\". Have a look at the Tcl/Tk"
 351     puts stderr "script \"$argv0\"!"
 352     exit 0
 353 }
 354
 355 set table [asn $asnfile]
 356
 357 foreach type [$table types] {
 358     if {[lindex [$table type $type] 0]=="$type pdu"} {
 359         set pdu $type
 360         break
 361     }
 362 }
 363
 364 readfile [lindex $argv 1]
 365 fillcomposer
 366
 367 update idletasks
 368 vwait done
 369
 370 $table close
 371 exit
 372