#!/usr/local/perl5.002/bin/perl

# ClassParser.pm - Read and parse a class definition file, build the
# global %classes hash.
# Copyright (C) 1996 Peter Orbaek <poe@daimi.aau.dk>
# This code is freely re-distributable under the GNU General Public License
# Version 1.0 11-May-96

package ClassParser;

require 5.002;
use vars qw(@ISA @EXPORT %classes);
use strict 'vars', 'subs';
use Exporter;
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(parseClassFile %classes);

# $tok is the lookahead symbol
my ($buffer, $tok, $lineno, $errs);
local (%classes);

sub syntax_error {
    $errs++;
    print STDERR "Syntax error in classfile at line $lineno, at '$tok'.\n";
    &gettoken;
}

sub gettoken {
    $tok = '*EOF*';
    return if (!defined $buffer);

    do {
	if ($buffer eq '') {
	    return unless (defined ($buffer = <CFILE>));
	    $buffer =~ s/\s*#.*$//;
	    $lineno++;
	}
	$buffer =~ s/^[;\s\n\t]*//; # treat ; as whitespace...
    } until ($buffer ne '');

    if ($buffer =~ /^([_\w][\[\]\{\}_\w\d]*)/) {
	$tok = $1;
	$buffer = substr $buffer, length($tok);
	return;
    }

    if ($buffer =~ /^(\S)/) {
	$tok = $1;
	$buffer = substr $buffer, 1;
	return;
    }
}

sub pClassName {
    &syntax_error unless ($tok =~ /^([_\w][_\w\d]*)$/);
    $classes{$tok}{autovivify} = 1;
    &gettoken;
}

sub pFieldName {
    &syntax_error unless ($tok =~ /^[_\w][_\w\d]*([\[\{][_\w][_\w\d]*[\]\}])?$/);
    &gettoken;
}

sub pFieldNameList {
    my ($fieldarr) = @_;

    push @$fieldarr, $tok;
    &pFieldName;
    if ($tok eq ',') {
	&gettoken;
	&pFieldNameList($fieldarr);
    }
}

sub pFieldSpec {
    my ($thisclass) = @_;
    my (@fields, $f, $cn);

    &pFieldNameList(\@fields);
    &syntax_error unless ($tok eq ':');
    &gettoken;
    $cn = $tok;
    &pClassName;
    # must wait till after pClassName for autovivification
    foreach $f (@fields) {
	$classes{$thisclass}{instancevars}{$f} = $classes{$cn};
    }
}

sub pData {
    my ($thisclass) = @_;
    while ($tok ne 'endclass' and $tok ne '*EOF*') {
	&pFieldSpec($thisclass);
    }
}

# list of classes $thisclass inherits from
sub pClassNameList {
    my ($thisclass) = @_;
    my ($super);

    $super = $tok;
    &pClassName;
    # must wait till after pClassName for autovivification
    $classes{$thisclass}{superclasses}{$super} = $classes{$super};
    $classes{$super}{subclasses}{$thisclass} = $classes{$thisclass};
    if ($tok eq ',') {
	&gettoken;
	&pClassNameList($thisclass);
    }
}

sub pInherits {
    my ($thisclass) = @_;

    &pClassNameList($thisclass);
}

sub pClassSpec {
    my ($thisclass);

    if ($tok eq 'class') {
	&gettoken;
	$thisclass = $tok;
	&pClassName;
	if ($tok eq 'inherits') {
	    &gettoken;
	    &pInherits($thisclass);
	} 
	if ($tok eq 'is') {
	    &gettoken;
	    &pData($thisclass);
	}
	&syntax_error unless ($tok eq 'endclass');
    }
}

sub pClassFile {
    do {
	&gettoken;
	&pClassSpec if $tok ne '*EOF*';
    } until ($tok eq '*EOF*');
}

sub parseClassFile {
    my ($file) = @_;

    open(CFILE, $file) || croak "can't open $file: $!\n";
    $lineno = 1;
    $buffer = '';
    $errs = 0;
    &pClassFile;
    close CFILE;
    return ($errs == 0);
}

1;