tab/rules2abs.tcl

   1 #!/usr/bin/tclsh
   2
   3 set prevtag {}
   4
   5 proc flushfields {f tag} {
   6     global specs absfile
   7
   8     if {[string compare $tag {}] == 0} {
   9         return
  10     }
  11     puts $f "elm $tag           $tag     -"
  12     foreach sub [array names specs] {
  13         puts -nonewline $f "elm $tag/$sub       ${tag}_${sub}   "
  14         set sep ""
  15         foreach spec [lsort -unique $specs($sub)] {
  16             puts -nonewline $f "$sep[lindex $spec 0]:[lindex $spec 1]"
  17             set sep ","
  18         }
  19         puts $f ""
  20         unset specs($sub)
  21     }
  22 }
  23
  24 set absfile [open danbib.abs w]
  25 set attrseq 1
  26
  27 puts $absfile "name danbib"
  28 puts $absfile ""
  29 puts $absfile "attset danbib.att"
  30 puts $absfile ""
  31 while {[gets stdin line] >= 0} {
  32     set ch [string index $line 0]
  33     if {[string compare $ch \#] && [scan $line "%s %s %s %s %s %s %s %s %s" tag class fieldid marcid prefixid subfields str cats format] > 6} {
  34
  35         if {[string compare $prevtag $tag]} {
  36             flushfields $absfile $prevtag
  37             set prevtag $tag
  38         }
  39         for {set i 0} {$i < [string length $subfields]} {incr i} {
  40             set subchar [string index $subfields $i]
  41             if {[string compare $fieldid {-}] != 0} {
  42                 set prefixid any
  43             }
  44             if {![info exists attr($prefixid)]} {
  45                 set attr($prefixid) $attrseq
  46                 incr attrseq
  47             }
  48             lappend specs($subchar) [list $prefixid [string tolower $class]]
  49         }
  50     }
  51 }
  52 if {[string compare $prevtag $tag]} {
  53     flushfields $absfile $prevtag
  54 }
  55 close $absfile
  56 set attfile [open danbib.att w]
  57 puts $attfile "name danbib"
  58 puts $attfile "reference Bib-1"
  59 puts $attfile ""
  60 foreach a [array names attr] {
  61     puts $a
  62     puts $attfile "att $attr($a)   $a"
  63 }
  64 close $attfile