yaz-asncomp

harvest是一个下载html网页得机器人

#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" "$@"
#
# yaz-comp: ASN.1 Compiler for YAZ
# (c) Index Data 1996-2003
# See the file LICENSE for details.
#
# $Id: yaz-asncomp,v 1.1 2003/05/27 21:12:23 adam Exp $
#

set yc_version 0.3

# Syntax for the ASN.1 supported:
# file   -> file module
#         | module
# module -> name skip DEFINITIONS ::= mbody END
# mbody  -> EXPORTS { nlist }
#         | IMPORTS { imlist }
#         | name ::= tmt
#         | skip
# tmt    -> tag mod type
# type   -> SEQUENCE { sqlist }
#         | SEQUENCE OF type
#         | CHOICE { chlist }
#         | basic enlist
#
# basic  -> INTEGER
#         | BOOLEAN
#         | OCTET STRING
#         | BIT STRING
#         | EXTERNAL
#         | name
# sqlist -> sqlist , name tmt opt
#         | name tmt opt
# chlist -> chlist , name tmt 
#         | name tmt 
# enlist -> enlist , name (n)
#         | name (n)
# imlist -> nlist FROM name
#           imlist nlist FROM name
# nlist  -> name
#         | nlist , name
# mod   -> IMPLICIT | EXPLICIT | e
# tag   -> [tagtype n] | [n] | e
# opt   -> OPTIONAL | e
#
# name    identifier/token 
# e       epsilon/empty 
# skip    one token skipped
# n       number
# tagtype APPLICATION, CONTEXT, etc.

# lex: moves input file pointer and returns type of token.
# The globals $type and $val are set. $val holds name if token
# is normal identifier name.
# sets global var type to one of:
#     {}     eof-of-file
#     \{     left curly brace 
#     \}     right curly brace
#     ,      comma
#     ;      semicolon
#     (      (n)
#     [      [n]
#     :      ::=
#     n      other token n
proc lex {} {
    global inf val type
    while {![string length $inf(str)]} {
        incr inf(lineno)
        set inf(cnt) [gets $inf(inf) inf(str)]
        if {$inf(cnt) < 0} {
            set type {}
            return {}
        }
	lappend inf(asn,$inf(asndef)) $inf(str)
        set l [string first -- $inf(str)]
        if {$l >= 0} {
            incr l -1
            set inf(str) [string range $inf(str) 0 $l]
        }
        set inf(str) [string trim $inf(str)]
    }
    set s [string index $inf(str) 0]
    set type $s
    set val {}
    switch -- $s {
        \{ { }
        \} { }
        ,  { }
        ;  { }
	\(  { }
	\)  { }
        \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
        :  { regexp {^::=} $inf(str) s }
        default {
             regexp "^\[^,\t :\{\}();\]+" $inf(str) s
             set type n
             set val $s
           }
    }
    set off [string length $s]
    set inf(str) [string trim [string range $inf(str) $off end]]
    return $type
}

# lex-expect: move pointer and expect token $t
proc lex-expect {t} {
    global type val
    lex
    if {[string compare $t $type]} {
        asnError "Got $type '$val', expected $t"
    }
}

# lex-name-move: see if token is $name; moves pointer and returns
# 1 if it is; returns 0 otherwise.
proc lex-name-move {name} {
    global type val
    if {![string compare $type n] && ![string compare $val $name]} {
        lex
        return 1
    }
    return 0
}

# asnError: Report error and die
proc asnError {msg} {
    global inf
   
    puts "Error in line $inf(lineno) in module $inf(module)"
    puts " $msg"
    error
    exit 1
}

# asnWarning: Report warning and return
proc asnWarning {msg} {
    global inf
   
    puts "Warning in line $inf(lineno) in module $inf(module)"
    puts " $msg"
}

# asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
# Uses $name as prefix. If there really is a list, $lx holds the C
# preprocessor definitions on return; otherwise lx isn't set.
proc asnEnum {name lx} {
    global type val inf

    if {[string compare $type \{]} return
    upvar $lx l
    while {1} {
	set pq [asnName $name]
        set id [lindex $pq 0]
	set id ${name}_$id
	lex-expect n
        lappend l "#define $inf(dprefix)$id $val"
	lex-expect ")"
        lex
        if {[string compare $type ,]} break
    }
    if {[string compare $type \}]} {
        asnError "Missing \} in enum list got $type '$val'"
    }
    lex
}

# asnMod: parses tag and modifier.
# $xtag and $ximplicit holds tag and implicit-indication on return.
# $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
# tagging; 0 otherwise.
proc asnMod {xtag ximplicit xtagtype} {
    global type val inf

    upvar $xtag tag
    upvar $ximplicit implicit
    upvar $xtagtype tagtype

    set tag {} 
    set tagtype {}
    if {![string compare $type \[]} {
        if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
            set tagtype ODR_$tagtype 
        } elseif {[regexp {^([0-9]+)$} $val x tag]} {
            set tagtype ODR_CONTEXT
        } else {
            asnError "bad tag specification: $val"
        }
	lex
    }
    set implicit $inf(implicit-tags)
    if {![string compare $type n]} {
        if {![string compare $val EXPLICIT]} {
            lex
            set implicit 0
        } elseif {![string compare $val IMPLICIT]} {
            lex
            set implicit 1
        }
    }
}

# asnName: moves pointer and expects name. Returns C-validated name.
proc asnName {name} {
    global val inf
    lex-expect n
    if {[info exists inf(membermap,$inf(module),$name,$val)]} {
	    set nval $inf(membermap,$inf(module),$name,$val)
	if {$inf(verbose)} {
	    puts " mapping member $name,$val to $nval"
	}
	if {![string match {[A-Z]*} $val]} {
	    lex
	}
    } else {
	set nval $val
	if {![string match {[A-Z]*} $val]} {
	    lex
	}
    }
    return [join [split $nval -] _]
}

# asnOptional: parses optional modifier. Returns 1 if OPTIONAL was 
# specified; 0 otherwise.
proc asnOptional {} {
    global type val
    if {[lex-name-move OPTIONAL]} {
        return 1
    } elseif {[lex-name-move DEFAULT]} {
	lex
	return 0
    }
    return 0
}

# asnSizeConstraint: parses the optional SizeConstraint.
# Currently not used for anything.
proc asnSizeConstraint {} {
    global type val
    if {[lex-name-move SIZE]} {
	asnSubtypeSpec
    }
}

# asnSubtypeSpec: parses the SubtypeSpec ...
# Currently not used for anything. We now it's balanced however, i.e.
# (... ( ... ) .. )
proc asnSubtypeSpec {} {
    global type val

    if {[string compare $type "("]} {
	return 
    }
    lex
    set level 1
    while {$level > 0} {
	if {![string compare $type "("]} {
	    incr level
	} elseif {![string compare $type ")"]} {
	    incr level -1
	}
	lex
    }
}

# asnType: parses ASN.1 type.
# On entry $name should hold the name we are currently defining.
# Returns type indicator:
#   SequenceOf     SEQUENCE OF
#   Sequence       SEQUENCE 
#   SetOf          SET OF
#   Set            SET
#   Choice         CHOICE
#   Simple         Basic types.
#   In this casecalling procedure's $tname variable is a list holding:
#        {C-Function C-Type} if the type is IMPORTed or ODR defined.
#      or
#        {C-Function C-Type 1} if the type should be defined in this module
proc asnType {name} {
    global type val inf
    upvar tname tname

    set tname {}
    if {[string compare $type n]} {
        asnError "Expects type specifier, but got $type"
    }
    set v $val
    lex
    switch -- $v {
        SEQUENCE {
	    asnSizeConstraint
	    if {[lex-name-move OF]} {
		asnSubtypeSpec
		return SequenceOf
	    } else {
		asnSubtypeSpec
		return Sequence
	    }
	}
	SET {
	    asnSizeConstraint
	    if {[lex-name-move OF]} {
		asnSubtypeSpec
		return SetOf
	    } else {
		asnSubtypeSpec
		return Set
	    }
        }
        CHOICE {
	    asnSubtypeSpec
            return Choice
        }
    }
    if {[string length [info commands asnBasic$v]]} {
        set tname [asnBasic$v]
    } else {
        if {[info exists inf(map,$inf(module),$v)]} {
            set v $inf(map,$inf(module),$v)
        }
        if {[info exists inf(imports,$v)]} {
            set tname $inf(imports,$v)
        } else {
            set w [join [split $v -] _]
            set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
        }
    }
    if {[lex-name-move DEFINED]} {
	if {[lex-name-move BY]} {
	    lex
	}
    }
    asnSubtypeSpec
    return Simple
}

proc mapName {name} {
    global inf
    if {[info exists inf(map,$inf(module),$name)]} {
        set name $inf(map,$inf(module),$name)
	if {$inf(verbose)} {
	    puts -nonewline " $name ($inf(lineno))"
	    puts " mapping to $name"
	}
    } else {
	if {$inf(verbose)} {
	    puts " $name ($inf(lineno))"
	}
    }
    return $name
}

# asnDef: parses type definition (top-level) and generates C code
# On entry $name holds the type we are defining.
proc asnDef {name} {
    global inf file

    set name [mapName $name]
    if {[info exist inf(defined,$inf(fprefix)$name)]} {
        incr inf(definedl,$name)
        if {$inf(verbose) > 1} {
            puts "set map($inf(module),$name) $name$inf(definedl,$name)"
        }
    } else {
        set inf(definedl,$name) 0
    }
    set mname [join [split $name -] _]
    asnMod tag implicit tagtype
    set t [asnType $mname]
    asnSub $mname $t $tname $tag $implicit $tagtype
}


# asnSub: parses type and generates C-code
# On entry,
#   $name holds the type we are defining.
#   $t is the type returned by the asnType procedure.
#   $tname is the $tname set by the asnType procedure.
#   $tag is the tag as returned by asnMod
#   $implicit is the implicit indicator as returned by asnMod
proc asnSub {name t tname tag implicit tagtype} {
    global file inf
   
    set ignore 0
    set defname defined,$inf(fprefix)$name
    if {[info exist inf($defname)]} {
        asnWarning "$name already defined in line $inf($defname)"
        set ignore 1
    }
    set inf($defname) $inf(lineno)
    switch -- $t {
        Sequence   { set l [asnSequence $name $tag $implicit $tagtype] }
        SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
	SetOf      { set l [asnOf $name $tag $implicit $tagtype 1] }
        Choice     { set l [asnChoice $name $tag $implicit $tagtype] }
        Simple     { set l [asnSimple $name $tname $tag $implicit $tagtype] }
        default    { asnError "switch asnType case not handled" }
    }
    if {$ignore} return

    puts $file(outc) {}
    puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
    puts $file(outc) \{
    puts $file(outc) [lindex $l 0]
    puts $file(outc) \}
    set ok 1
    set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
    switch -- $t {
        Simple {
            set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
            if {![string compare [lindex $tname 2] 1]} {
                if {![info exist inf(defined,[lindex $tname 0])]} {
                    set ok 0
                }
            }
	    set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
	    incr inf(nodef)
        }
        default {
            set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
	    set inf(var,$inf(nodef)) "[lindex $l 1];"
	    incr inf(nodef)
        }
    }
    if {$ok} {
        puts $file(outh) {}
        puts $file(outh) $decl
        puts $file(outh) $fdef
	asnForwardTypes $name
    } else {
        lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
        lappend inf(forward,ref,[lindex $tname 0]) $name
    }
}

proc asnForwardTypes {name} {
    global inf file

    if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
	return 0
    }
    foreach r $inf(forward,code,$inf(fprefix)$name) {
	puts $file(outh) $r
    }
    unset inf(forward,code,$inf(fprefix)$name)

    while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
	set n $inf(forward,ref,$inf(fprefix)$name)
	set m [lrange $n 1 end]
	if {[llength $m]} {
	    set inf(forward,ref,$inf(fprefix)$name) $m
	} else {
	    unset inf(forward,ref,$inf(fprefix)$name)
	}
	asnForwardTypes [lindex $n 0]
    }
}

# asnSimple: parses simple type definition and generates C code
# On entry,
#   $name is the name we are defining
#   $tname is the tname as returned by asnType
#   $tag is the tag as returned by asnMod
#   $implicit is the implicit indicator as returned by asnMod