# ParseBib.pm - bib file parsing routines
# (c) Martin Matousek, 2002-06-03

=head1  NAME

ParseBib - BIB file parsing routines

=head1  SYNOPSIS

use ParseBib;

=head1  DESCRIPTION

=head2 Members

=over 4

=item $scr->{ 'Rows' };

=item $scr->{ 'Cols' };

=back

=head2 Methods

=over 4

=cut
use lib '/home.dokt/xmatousm/bib/bib/';


package Bib;
#require Exporter;
use TeX;
use strict;
use warnings;
use FileHandle;
use Opts;

BEGIN {
  Opts::add_opts( "[-shortnames] [-nowarn] [-verbose=n]\n",
                  'shortnames' => 'b', 
                  'nowarn' => 'b', 
                  'verbose' => 'd' );
}


sub  new
{
    return bless( { '-keys' => [] }, ref( $_[0] ) || $_[0] );
}

sub misfield
{
    my ( $fl, $fld, $type, $key, $opts ) = @_;
    $opts->{'nowarn'} or 
        print STDERR "$fl: missing '$fld' in $type entry $key.\n";
}

sub find_fld {
    my ( $this, $obj, $fld, $opts ) = @_;

    defined( $obj->{$fld} ) and return 1;

    $opts->{'nocrossref'} and $obj->{'-crossref'} and 
        return $this->find_fld( $obj->{'-crossref'}, $fld, $opts );
    return 0;
}

sub test_required_fields
{
    my ( $this, $Key, $opts ) = @_;
    my $flds = undef;
    my $obj = $this->{$Key};
    my $type = $obj->{'-type'};
    my $fl = ref( $obj->{'fl'} ) ? $obj->{'fl'}{'-key'} : $obj->{'fl'};

    $type eq 'string' and return;
    $type eq 'inproceedings' and do {
        $flds = [ 'author', 'title', 'pages',
                  'booktitle', 'editor', 'publisher', 'address',
                  'month', 'year', 'day' ];
    };
    $type eq 'article' and 
        $flds = [ 'author', 'title', 'journal', 'year',
                  'volume', 'number', 'pages', 'month' ];
    $type eq 'techreport' and return;
    $type eq 'proceedings' and 
        $flds = [ 'editor', 'title', 'booktitle',  'year' ];

    $type eq 'book' and 
        $flds = [ 'author', 'title', 'year' ];

    $type eq 'inbook' and 
        $flds = [ 'author', 'title', 'year' ];


    $type eq 'unpublished' and return;

    if( defined( $flds ) )
    {
        foreach my $f (@{$flds} )
        {
            $this->find_fld( $obj, $f, $opts ) or 
                misfield( $fl, $f, $type, $Key, $opts );
        }
        return;
    }
    else
    {
        $opts->{'nowarn'} or 
            print STDERR "$fl: unknown entry type '$type'\n";
    }

}


sub resolve
{
    my ( $this, $opts ) = @_;
    foreach my $Key ((@{$this->{'-keys'}}))
    {
        $this->resolve_strings( $Key, !$opts->{'nocrossref'}, $opts );
        $this->resolve_crossref( $Key, !$opts->{'nocrossref'}, $opts );
        $this->resolve_people( $Key, 'author', $opts );
        $this->resolve_people( $Key, 'editor', $opts );
        $this->test_required_fields( $Key, $opts );

    }
}

sub resolve_strings
{
    my ( $this, $Key, $Replace,$opts ) = @_;
    my $fl;

    $this->{$Key}{'-type'} eq 'string' and return;
    foreach my $k (keys( %{$this->{$Key}} ) ) {
        $fl = $this->{$Key}{'fl'}{$k} || '???';
        $k =~ /^-/ and next;
        ref( $this->{$Key}{$k} ) and $this->{$Key}{$k}{'string'} and do {
            my $kstr = $this->{$Key}{$k}{'string'};
            $kstr =~ /^(jan|feb|mar|apr|may|jun|jul|aug|sep|nov|oct|dec)$/ and 
                next;
            my $str = $this->{$kstr};
            if( defined( $str ) ) {
                if( $str->{'-type'} eq 'string' ) {
                    $Replace and $this->{$Key}{$k} = $str->{'-val'};
                } else {
                    $opts->{'nowarn'} or
                        print STDERR "$fl: keyword '$kstr' is not a string\n";
                }
            } else {
                $opts->{'nowarn'} or
                    print STDERR "$fl: string '$kstr' is not defined\n";
            }
        };
    }
}


sub resolve_crossref
{
    my ( $this, $Key, $Replace,$opts ) = @_;
    my $cr = $this->{$Key}{'crossref'};
    my $fl = ref($this->{$Key}{'fl'}) ? $this->{$Key}{'fl'}{'crossref'} : '???';

    if( defined( $cr ) )
    {
        if( defined( $this->{$cr} ) )
        {
            $this->{$Key}{'-crossref'} = $this->{$cr};
            if( $this->{$cr}{'-type'} eq 'string' )
            {
                $opts->{'nowarn'} or
                    print STDERR "$fl: crossref '$cr' is string\n";
            }
            elsif( $Replace )
            {
                if( defined( $this->{$cr}{ 'crossref' } ) )
                {
                    $this->resolve_crossref( $cr, 1, $opts );
                }

                foreach my $crk( keys( %{$this->{$cr}} ) )
                {
                    if( !defined( $this->{$Key}{$crk} ) )
                    {
                        $this->{$Key}{$crk} = $this->{$cr}{$crk};
                        $this->{$Key}{'fl'}{$crk} = 
                            $this->{$cr}{'fl'}{$crk};
                    }
                }
            }
        }
        else
        {
            $opts->{'nowarn'} or
                print STDERR "$fl: unresloved crossref '$cr'\n";
        }
    }
}

# SubKey: author, editor
sub resolve_people
{
    my ( $this, $Key, $SubKey, $opts ) = @_;
    my $au = $this->{$Key}{$SubKey};
    my $fl = ref($this->{$Key}{'fl'}) ? $this->{$Key}{'fl'}{$SubKey} : '???';

    ref( $au ) and return;
    if( defined( $au ) )
    {
        defined( $fl ) or print ">>>$Key, $SubKey<<<\n";
        $au =~ s/\n/ /;
        my @authors = split /\band\b/, $au;

        if( $opts->{'linearizepeople'} )
        {
            $this->{$Key}{$SubKey} = [];
        }
        foreach my $a ( @authors )
        {
            $a =~ s/\s+/ /g;
            $a =~ s/^\s*//;
            $a =~ s/\s*$//;

            if( $opts->{'linearizepeople'} )
            {
                push @{$this->{$Key}{$SubKey}}, $a;
            }

            # von|van|de la, last, first+second, jr
            my @names = split ',', $a;

            if( $#names == 1 )  # von Last, First
            {
                $names[3] ='';
                $names[2] = $names[1];
            }
            elsif( $#names == 2 ) # von Last, Jr, First
            {
                $names[3] = $names[1];
                $names[3] =~ /^\s*Jr\s*$/ or do {
                    $opts->{'nowarn'} or
                        print STDERR "$fl: strange Jr-part '$names[3]'\n";
                    next;
                }
            }
            else
            {
                $opts->{'nowarn'} or
                    print STDERR "$fl: strange name '$a' ggg\n";
                next;
            }

            if( $names[0] =~ /^\s*(van |Van |von |de\s+la )/ )
            {
                $names[1] = $';  #';
                $names[0] = $1;
            }
            else
            {
                $names[1] = $names[0];
                $names[0] = '';
            }

            test_name( \$names[1], 0, $opts ) or 
                $opts->{'nowarn'} or
                    print STDERR "$fl: strange lastname '$names[1]'\n";
            test_name( \$names[2], $opts->{ 'shortnames' } ? 3 : 2, $opts ) or 
                $opts->{'nowarn'} or
                    print STDERR "$fl: strange firstname '$names[2]'\n";


        }

    }
}


sub test_name
{
    my $tx = shift;
    my $more = shift;
    my $opts = shift;

    $$tx =~ s/^\s*//;
    $$tx =~ s/\s*$//;
    $$tx =~ s/\s+/ /g;

    $_ = $$tx;
    s/~/ /g;

    if( $opts->{ 'wchar' } ) {
        s/\p{Lu}/A/g;
        s/\p{Ll}+/a/g;
    } else {
        s/\{\s*\\(v |\`|o |\"|\'|accent23)\s*([A-Z])\s*\}/A/g;
        s/\{\s*\\AA\s*\}/A/g;
        s/\{\s*\\(v |\`|o |\"|\'|accent23)\s*([a-z]|\\i)\s*\}/a/g;
        s/[A-Z]/A/g;
        s/[a-z]+/a/g;
    }

    /\d/ && return 0;

#    print "$more: $_\n";
    return ( /^Aa(-Aa)*$/ or 
        $more > 0 and /^Aa(-Aa)*(\ Aa)*$/  or
        $more > 1 and /^Aa(-Aa)*(\ Aa?\.)*$/  or
        $more > 2 and /^A\.(\ A\.)*$/ );

}


1;
