# bibtex.tcl --
#
#      A basic parser for BibTeX bibliography databases.
#
# Copyright (c) 2005 Neil Madden.
# License: Tcl/BSD style.

package require Tcl 8.4
package provide bibtex 0.3

# A rough grammar (case-insensitive):
#
# Database        ::= (Junk '@' Entry)*
# Junk                ::= .*?
# Entry        ::= Record
#                |   Comment
#                |   String
#                |   Preamble
# Comment        ::= "comment" [^\n]* \n                -- ignored
# String        ::= "string" '{' Field* '}'
# Preamble        ::= "preamble" '{' .* '}'         -- (balanced)
# Record        ::= Type '{' Key ',' Field* '}'
#                |   Type '(' Key ',' Field* ')' -- not handled
# Type                ::= Name
# Key                ::= Name
# Field        ::= Name '=' Value
# Name                ::= [^\s\"#%'(){}]*
# Value        ::= [0-9]+
#                |   '"' ([^'"']|\\'"')* '"'
#                |   '{' .* '}'                         -- (balanced)

namespace eval bibtex {
    variable id 0
    variable data
    array set data { }
 
    # bibtex::parse --
    #
    #        Parse a bibtex file.
    #
    # parse ?options? ?bibtex?
    # where options can be:
    #        -recordcommand cmd        -- callback for each record
    #        -preamblecommand cmd        -- callback for @preamble blocks
    #        -stringcommand cmd        -- callback for @string macros
    #        -commentcommand cmd        -- callback for @comment blocks
    #        -progresscommand cmd        -- callback to indicate progress of parse
    proc parse {args} {
        variable data
        variable id
 
        # Argument processing
        if {[llength $args] < 1} {
            set err "[lindex [info level 0] 0] ?options? ?bibtex?"
            return -code error "wrong # args: should be \"$err\""
        }
        set token bibtex[incr id]
        array set options {
            -async                0
            -blocksize                1024
        }
        set options(-stringcommand) [list [namespace current]::addStrings $token]
        if {[llength $args] % 2 == 1} {
            set data($token,buffer) [lindex $args end]
            set data($token,eof) 1
            array set options [lrange $args 0 end-1]
        } else {
            set data($token,buffer) ""
            set data($token,eof) 0
            array set options [lrange $args 0 end]
            if {![info exists options(-channel)]} {
                cancel $token
                return -code error "no channel and no data given"
            }
            if {$options(-async)} {
                fileevent $options(-channel) readable \
                    [list [namespace current]::ReadChan $token]]
            } else {
                # Snarf it all up in one go for now
                set data($token,buffer) [read $options(-channel)]
                set data($token,eof) 1
            }
        }
        foreach {k v} [array get options] { set data($token,$k) $v }
        # String mappings
        set data($token,strings) { }
        if {$options(-async)} {
            cancel $token
            error "not implemented"
        } else {
            ParseRecords $token
        }
    }

    # Cleanup a parser, cancelling any callbacks etc.
    proc cancel {token} {
        variable data
        if {[info exists $data($token,channel)]} {
            fileevent $data($token,channel) readable {}
        }
        foreach key [array names data $name,*] {
            unset data($key)
        }
    }

    # bibtex::addStrings --
    #
    #        Add strings to the map for a particular parser. All strings are
    #        expanded at parse time.
    proc addStrings {token strings} {
        variable data
        eval [list lappend data($token,strings)] $strings
    }

    # Private utility routines =================================
    proc Callback {token type args} {
        variable data
        if {[info exists data($token,-${type}command)]} {
            if {$data($token,-async)} {
                after 0 $data($token,-${type}command) $args
            } else {
                eval $data($token,-${type}command) $args
            }
        }
    }

    proc ReadChan {token} {
        variable data
        set chan $data($token,-channel)
        append data($token,buffer) [read $chan]
        if {[eof $chan]} {
            set data($token,eof) 1
        }
    }

    proc ParseRecords {token} {
        variable data
        set bibtex $data($token,buffer)
 
        # Run through each block
        set db [regexp -all -inline {((?:[^@]|\S@|[^\n][\r\t\f ]*@)*)\s?@} $bibtex]
        set total [expr {([llength $db]-2)/2}]
        set step [expr {double($total) / 100.0}]
        set istep [expr {$step > 1 ? int($step) : 1}]
        set count 0
        foreach {_ block} [lrange $db 2 end] {
            if {([incr count] % $istep) == 0} {
                Callback $token progress [expr {int($count / $step)}]
            }
            if {[regexp -nocase {\s*comment([^\n])*\n(.*)} $block \
                -> cmnt rest]} {
                # Are @comments blocks, or just 1 line?
                # Does anyone care?
                Callback $token comment $cmnt
            } elseif {[regexp -nocase {\s*string[^\{]*\{(.*)\}[^\}]*} \
                $block -> rest]} {
                # string macro defs
                Callback $token string [ParseBlock $rest]
            } elseif {[regexp -nocase {\s*preamble[^\{]*\{(.*)\}[^\}]*} \
                $block -> rest]} {
                Callback $token preamble $rest
            } elseif {[regexp {([^\{]+)\{([^,]*),(.*)\}[^\}]*} $block -> \
                type key rest]} {
                # Do any @string mappings (these are case insensitive)
                set rest [string map -nocase $data($token,strings) $rest]
                Callback $token record [Tidy $type] [string trim $key] \
                    [ParseBlock $rest]
            } else {
                puts stderr "Skipping: $block"
            }
        }
    }

    proc Tidy {str} {
        string tolower [string trim $str]
    }

    proc ParseBlock {block} {
        set ret [list]
        set index 0
        while {1} {
            if {[regexp -start $index -indices -- {(\S+)[^=]*=(.*)} $block -> \
                key rest]} {

                foreach {ks ke} $key { break }
                set k [Tidy [string range $block $ks $ke]]
                foreach {rs re} $rest { break }
                foreach {v index} \
                    [ParseBibString $rs [string range $block $rs $re]] \
                    { break }
                lappend ret $k $v
            } else { break }
        }
        return $ret
    }

    proc ParseBibString {index str} {
        set count 0
        set retstr ""
        set escape 0
        foreach char [split $str ""] {
            incr index
            if {$escape} {
                set escape 0
            } else {
                if {$char eq "\{"} {
                    incr count
                    continue
                } elseif {$char eq "\}"} {
                    incr count -1
                    if {$count < 0} { incr index -1; break }
                    continue
                } elseif {$char eq ","} {
                    if {$count == 0} { break }
                } elseif {$char eq "\\"} {
                    set escape 1; continue
                } elseif {$char eq "\""} { continue }
            }
            append retstr $char
        }
        regsub -all {\s+} $retstr { } retstr
        return [list [string trim $retstr] $index]
    }
}
proc readfile file {
    set fd [open $file]
    set cn [read $fd]
    close $fd
    return $cn
}
proc progress {percent} {
     set str [format "Processing: \[%3d%%\]" $percent]
     puts -nonewline "\r$str"; flush stdout
}
proc count {type key data} {
     global count total
     if {[info exists count($type)]} {
         incr count($type)
     } else {
         set count($type) 1
     }
     incr total
}
array set count { }
set total 0
puts -nonewline "Processing: \[  0%\]"; flush stdout
bibtex::parse \
    -recordcommand count \
    -progresscommand progress [readfile [lindex $argv 0]]
puts ""
puts "Summary ======"
puts "Total: $total"
parray count