
##  Copyright (c) 1997-2001 Ivan Kurmanov. All rights reserved.
##
##  This code is free software; you can redistribute it and/or modify it
##  under the same terms as Perl itself.


# old comments:

# The module's purpose is checking ReDIF data files for correctness. ReDIF is
# more or less complex data format and keeping in mind it's machine readability
# requirements a lot of possible mistakes in (possibly human-written) data 
# files should be identified at the early stage, ensureing that all the 
# rest (or just some) other processing software will receive error-free
# data in a more 
# standardized (machine-readable) format. So we can eliminate (to some basic
# general extent) need for error checking and preprocessing procedures in other
# software dealing with data.
#
# The module designed in such a way, that it need not to be changed if some
# basic (non-principal) changes to ReDIF data format happen. It reads a text 
# file, currently "/RePEc/all/conf/redif.spec" and extracts ReDIF format 
# specification from this file, building some corresponding complex
# data structures in memory.
# This stuctures include all template types and all cluster types and all
# attributes of templates and clusters (apart from Template-Type attribute
# itself which is hard-coded inside the module). It also gets
# information about attributes' specific properties like value type, 
# repeatability, or being the key attribute of a cluster or being 
# a required attribute in a template or cluster.
#
###############################################################################


package ReDIF::Parser::Core;

$VERSION = do { my @r=(q$Revision: 1.46 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r }; 
#                   $Id: Core.pm,v 1.46 2003/11/21 14:10:21 ivan Exp $

#################################################################################
###    P A C K A G E     P A R S E R    C O R E 
#################################################################################

# no strict;



use ReDIF::Spec;
use ReDIF::Parser::Special;
use ReDIF::Parser::Output;

require Exporter;

use vars qw( @EXPORT_OK @ISA $value $Result 
	     $input_file_position $ignore_attributes_mode 
	     $X 
	     
	     $file

	     $the_attribute 
	     $attribute_short

	     $prefix
	     $OUTPUT 
	     $DEBUG

	     $current_record_object

	     );

# $DEBUG = 1;  ###  DEBUGGING

@ISA = qw( Exporter );
@EXPORT_OK = qw( ResetFile );

use Carp;

# use utf8;                       ###  UNICODE

use ReDIF::Unicode qw( &has_non_latin1_unicode &latin1_from_utf8 ) ;


use strict;  ### broken in perl 5.6.1 !

use ReDIF::Parser::NO_UTF8;



# %::HashT = ();
my $the_record_object ; # = \%::HashT; 
                        # global template-hash
my $latest_template_object;
my @open_records_stack = ( );

$Result = 0;    ### template status 

my $specification ;
my $template_start_attributes;

my @open_context_names_stack = ('zero');
my @open_prefixes_stack  = ('');

my $current_context_object;
my $current_context_showname;
my $current_context_name;

my $current_prefix;

my $attr_specification;

my $current_errors_counter = 0;
my $current_warnings_counter = 0;

my $file_errors_counter = 0;
my $file_message_countu = 0;
my $file_any_messages   = 0;

my $all_attributes_count;
my $files_errors_counter;

my $line_number;


###  UNICODE

use vars qw(
    $OUTPUT_ENCODING 
    $TEMPLATE_EXPRESSIBLE_IN_LATIN1
    $attribute_remembered
    $Options
    );

my $good_template_text ;


my @template_type_attribute;

my $attribute_is_bad;

my $notices;
my $multiple_values_template_hash = 0;

#########################################################################
# SUB MSG
#########################################################################
# output messages are sent out (can be sent out) through this routine.
# It depends on $mode variable.

sub msg {
    my ( $m, $t ) = @_;

    if ( $t>2 ) {
        $current_errors_counter ++ if $t < 10;
        $Result=-1 if $t < 10;

    } elsif ($t==2) {
        $current_warnings_counter ++;
    }

    if( $OUTPUT_ENCODING eq 'latin1' ) {  ### UNICODE
	$m = latin1_from_utf8 ( $m );
    }
    
    $OUTPUT->add_message( $m, $t );
}


use Carp;

sub message {
    my ( $m, $level, $for_prev_attr ) = @_;

    if ( not defined $level or $level !~ /\d/ ) {
	confess;
    }
    if ( $level>2 ) {
        $current_errors_counter ++ ;
        $Result=-1;

    } elsif ($level==2) {
        $current_warnings_counter ++;
    }

    if( $OUTPUT_ENCODING eq 'latin1' ) {  ### UNICODE
	$m = latin1_from_utf8 ( $m );
    }
    $OUTPUT->add_message( "(line $line_number): $m", $level, $for_prev_attr );

}


sub error {
    my $text = shift;
    my $for_prev_attr = shift;
    $current_errors_counter ++;
    $Result = -1;

    if( $OUTPUT_ENCODING eq 'latin1' ) {  ### UNICODE
	$text = latin1_from_utf8 ( $text );
    }
    $OUTPUT->add_message( "(line $line_number): $text", 3, $for_prev_attr );
}


sub warning {
    my $text = shift;
    my $for_prev_attr = shift;
    $current_warnings_counter ++;

    if( $OUTPUT_ENCODING eq 'latin1' ) {  ### UNICODE
	$text = latin1_from_utf8 ( $text );
    }
    
    $OUTPUT->add_message( "(line $line_number): $text", 2, $for_prev_attr );
}

sub notice {
    my $text = shift;

    if( $OUTPUT_ENCODING eq 'latin1' ) {  ### UNICODE
	$text = latin1_from_utf8 ( $text );
    }

#    warn "(line $line): $text";
    $OUTPUT->add_message( "(line $line_number): $text", 0 );
}


#########################################################################
# SUB INIT  #  Initialization
#########################################################################
#
sub init {
    my $options = shift;

    if( $options ) {
	$Options = $options;
    } else {
	$Options = \%rr::Options;
    }

   
    if( not defined $Options->{'message_threshold'} ) {
	$Options->{'message_threshold'} = 2;
    }

    my $threshold = $Options->{'message_threshold'};

    print "Parser Core init: " , 
    "message threshold = " , 	$threshold, "\n" 
	if $DEBUG;
    
    undef $OUTPUT;
    $OUTPUT = ReDIF::Parser::Output-> new 
	( 
	  threshold => $threshold,
	  );

    if( $threshold < 2 ) { $notices = 1; } else { $notices = 0; }

    my $input_options = {
	redif_specification => $Options->{redif_specification},
	remove_newline_from_values =>
	    $Options -> {remove_newline_from_values},
		
	    };    

    $input_options->{'attribute_output'} = 'ReDIF::Parser::Core';

    ### UNICODE
    if ( exists $Options->{utf8_output} and $Options->{utf8_output} ) {
	$OUTPUT_ENCODING = 'utf-8';
    } else {
	$OUTPUT_ENCODING = 'latin1';
    }

    if( $Options->{'quote_source'} ) {
	if ( $Options->{utf8_output} ) {
	    $input_options->{'output_source_utf8'} = $OUTPUT;
	} else {
	    $input_options->{'output_source'} = $OUTPUT;
	}
    }

    if( $Options->{'use_parser_input'} ) {
	use ReDIF::Parser::Input;
	&ReDIF::Parser::Input::init( $input_options );
    }
        

    my $cons=0;

    if( $Options->{'redif_specification'} ) {
	###  ReDIF::Spec object
	$specification = $Options->{'redif_specification'} ;
    }

    die "can't go on without a valid specification"
	if not $specification or not $specification -> ok ();

    warn "specification is fine! ($specification->{filename})"
	if $DEBUG;

    $template_start_attributes = $specification->{starters};

    $current_context_object = $specification->context( 'zero' );
    current_context_changed( );

    $Result = -5;

    return 1 ;
}


#########################################################################
#     S T A R T I N G    N E W    F I L E  
#########################################################################
# execute it before reading a file

sub starting_new_file {
    $file = shift;

    if( defined $the_record_object 
	and not $the_record_object->{'CLOSED'} ) {
	### XXX  Should not happen (normally)
#	die "INTERNAL ERROR, that shouldn't have happened. Please report to the ReDIF-perl author";
	close_current_template();

    } else {
      $current_errors_counter = 0;
      $current_warnings_counter = 0;
    }

    $Result = -1;
    $file_errors_counter = 0;
    $file_any_messages   = 0;
    die if not $specification;

    $OUTPUT->clear();
#    undef $the_record_object;

}

sub ResetFile {
    starting_new_file( @_ );
}


sub get_current_file_message_status { return $file_any_messages;  }

sub get_current_template_status {
    if    ( $Result == 0  ) { return "good unfin"; } 
    elsif ( $Result == -1 ) { return "bad unfin";  }
    elsif ( $Result == 5  ) { return "good";        } 
    elsif ( $Result == -5 ) { return "bad";        }
    return "";
}

sub get_current_template { return $the_record_object;  }


#########################################################################
# SUB   THE ATTRIBUTE 
#########################################################################
# This is the new entry point into the Parser::Core (rc2) processing
#
sub the_attribute {

    my $p;  ### package name

    ($p, $the_attribute, $value, $input_file_position, $line_number ) = @_;

    $X = 0;

    if ( ($Result == 5) or ($Result == -5) ) {
	warn "template status cleared"
	    if $DEBUG;
	$Result = 0;
    }

    if( not defined $line_number ) {
	$line_number = "unknown, file position $input_file_position";
    }

    $attribute_remembered = 0;
    $attribute_short = '';

#    use Carp::Assert;
#    assert( defined $the_attribute );

    if ( not defined ($value) ) {
	generalclose();
	return $Result;


    } elsif ( not defined $the_attribute
	      or $the_attribute eq '' ) {
	
	if ( length($value) > 70) { substr ($value, 60) = "..."; }
	error "bad line: '$value'";
	return $Result;
	
    } elsif ( $template_start_attributes -> {$the_attribute} ) {
	process_template_start_attribute ();
	return $Result;
	
    }

    if ( defined( $the_attribute ) and $the_attribute =~ /^X\-/i ) {
	$X = 1;
    }
	
    check_the_attribute( );
    $all_attributes_count++;
    
    warn "processed attribute '$the_attribute' "
	if $DEBUG;
    return $Result;
}


#########################################################################


sub close_current_template {

    my $self = shift;  ### not used
    my $md5_checksum = shift;

    my $c;
    until ( $current_context_name eq 'zero') { 
	warn "closing context $current_context_name"
	    if $DEBUG;
	close_current_context(); 
	$c =1;
    }


    if( $the_record_object -> {'CLOSED'} ) {
###   happens sometimes, but that's not something to go mad about
#	Carp::cluck( "closing an already closed template!" );
	
	return;
    }
    $the_record_object->{CLOSED} = 1;

    if ($Result == -1) { $Result = -5;}
    else { $Result = 5;}
    warn "set Result to [$Result]"
	if $DEBUG;

    ###   UNICODE
    ###   mark as invalid templates with non-latin1 data
    $the_record_object ->{ENCODING} = $OUTPUT_ENCODING ;

    if ( $OUTPUT_ENCODING eq 'latin1' ) {

      if ( not $TEMPLATE_EXPRESSIBLE_IN_LATIN1 ) {
	$the_record_object ->{ENCODING} = "invalid" ;	    
	if ( $Result == 5 ) { 
	  $Result = -5;
	}
      }	
    }

    
    if ( $good_template_text ) {
	$the_record_object ->{TEXT} = $good_template_text ;
    }
    $the_record_object ->{REPORT}   = $OUTPUT->get_text();
    $the_record_object ->{PROBLEMS} = $OUTPUT->get_messages() ;
    $the_record_object ->{RESULT}   = get_current_template_status() ;
    $the_record_object ->{ERRORS}   = $current_errors_counter ;
    $the_record_object ->{MESSAGES} = $OUTPUT-> messages_count() ;
    $the_record_object ->{WARNINGS} = $current_warnings_counter ;

    # a hack of a kind, 2003-02-02 04:52
    # XXX: ReDIF-specific
    if ( $multiple_values_template_hash ) {
      $the_record_object ->{ID}     = $the_record_object ->{handle} ->[0];
    } else {
      $the_record_object ->{ID}     = $the_record_object ->{handle};
    }

    if( ReDIF::Parser::calculate_md5_checksum ) {
	$the_record_object ->{MD5SUM} = $md5_checksum ;
    }

    if( $OUTPUT->messages_count() ) {
	$file_any_messages = 1;
    }

    $OUTPUT->clear();

    if( $current_errors_counter ) {
	$files_errors_counter += $current_errors_counter;
    }
    $current_errors_counter = 0;
    $current_warnings_counter = 0;

}


###################################################################################
###    P R O C E S S    T E M P L A T E    S T A R T    A T T R I B U T E     #####
###################################################################################

sub process_template_start_attribute {

    $attribute_remembered = 0;

   ############################################################
   #
   #  Special treatment of the template-type attribute
   #
    # XXX: ReDIF-specific
    if (not $value =~ /^ReDIF-[A-Z][a-z]+\s[\d\.]+/) {
	$value =~ s/ReDIF-([a-zA-Z]+)/ReDIF-\u\L$1/i ;
    }
    my $v = $value;
    $v =~ tr/A-Z/a-z/;

    $attribute_short = $the_attribute;
    
    before_template_start( );

    notice "process template type attribute"
	if $notices;

    my $c_template = $specification -> template_type_id( $v );

    if ( not $c_template ) {

	my $t_cont = $specification -> context( 'template' ) ;
	open_context( $t_cont );

	remember_attribute ();
	error "Unknown template type '$value' used";
	$ignore_attributes_mode = 1;
	return;
    } 

    my $t_cont = $specification -> context( $c_template ) ;

    open_context( $t_cont );
    
    $attr_specification = $t_cont -> {$the_attribute};
    
    $current_context_object -> {OK} = 1;

    # a hack, 2003-02-02 04:56: 
    $current_record_object -> {TYPE} = $value;

    update_statistics( );

    $ignore_attributes_mode=0;

    remember_attribute(); 

    return;
 }



#########################################################################
#        C H E C K   T H E    A T T R I B U T E
#########################################################################
# second and main stage of processing attributes
#
sub check_the_attribute {

for (1) {

    my $context = $current_context_object;
    
    warn "check_the_attribute" 
	if $DEBUG;

    notice "Check context <$current_context_showname> for '$the_attribute'" 
	if $notices;

    if ( ($current_context_name eq 'zero') and not $ignore_attributes_mode ) {
	if ( not $template_start_attributes->{$the_attribute} ) {
	    error "Start templates with 'template-type' attribute, not '$the_attribute'";
	    $ignore_attributes_mode = 1;
	    warn "bad attribute $the_attribute"
		if $DEBUG;
	    return;
	}
    }

    my $prefix = $open_prefixes_stack[$#open_context_names_stack];
    my $attr_prefix ;

    my $attribute_is_here ;

    if( not $prefix ) {
	if ( $current_context_object -> {$the_attribute} ) {
#	    warning "attribute is here: $the_attribute";
	    $attr_prefix = '';
	    $attribute_short   = $the_attribute;
	    $attribute_is_here = 1;
#	    warn;
#	    die;
	}
    } else {

	for (1) {
	    my $pre_len  = length( $prefix );
	    if( length ( $the_attribute ) <= $pre_len ) { last ; }

	    my $at_pre   = substr( $the_attribute, 0, $pre_len );
	    my $at_short = substr( $the_attribute, $pre_len );
	    if( $at_pre eq $prefix ) {
		if( $current_context_object->{$at_short} ) {
		    
		    $attr_prefix       = $at_pre;
		    $attribute_short   = $at_short;
		    $attribute_is_here = 1;
		}
	    }
	}
    }


    if( not $attribute_is_here ) {
	
	$attr_prefix = find_context_for_attribute( $context );
	
	if (not defined $attr_prefix ) {
	    if ( not $ignore_attributes_mode ) {
		warn "attribute wasn't identified" 
		    if $DEBUG;
		bad_unknown_attribute();
	    }
	    return ;
	}

	if ( $X )  {   #### "X-" attribute 
	
	    notice "Put the X- attribute '$the_attribute' into '$attr_prefix' context"
		if $notices;

	    while ( 1 ) {
		
		if( $attr_prefix eq $current_prefix ) {
		    $attribute_remembered = 0;
		    $attribute_is_bad     = 0;
		    notice "Remember: '$attribute_short' in '$current_prefix'"
			if $notices;
		    remember_attribute () 
			if $Options->{'x_attributes'};
		    last; 
		}
		if( not defined $current_prefix or $current_prefix eq '' ) { 
		    last;
		}
		close_current_context ( );
	    }
	    return;
	}
    }


    if ( $prefix eq $attr_prefix ) { 

	warn "attribute $the_attribute is here"
	    if $DEBUG;

	#  a sanity check 
	if ( not defined $context->{$attribute_short} )  {
	    die "bad internal error;";
	}

	$attr_specification = $context -> {$attribute_short};
	my $switch = $attr_specification -> {switch};
	my $prefix = $attr_specification -> {prefix};
	my $key    = $attr_specification -> {key};


        if ( $switch )  {

	    ###  record the event of appearing of this attr
            update_statistics( );  

            if ( defined $specification->context( $switch ) ) {
		open_context ( $specification->context( $switch ), 
			       $prefix );
		redo;

            } else {
		die "INTERNAL ERROR: context not found! "
		    . "contexts data structures inconsistency!";
            }

        } elsif ( $key ){
            if ( $context -> {'OK'} ) {
		notice "Restarting context -- key attribute came again"
		    if $notices;
                close_current_context () ;
		redo;

            } else {
                $context -> {'OK'}=1;
                update_statistics( );
                check_the_attribute_value( );
            }

        } else {
            update_statistics( );
            check_the_attribute_value( );
        }

    } else {
	warn "changing context for the attribute $the_attribute"
	    if $DEBUG;
        notice "NOT FOUND in current context. Falling back to the previous one."
	    if $notices;
        if ( close_current_context() ) {
	    redo;
        } else {
	    die "Internal error: because sub find_context_for_attribute should have returned 0";
        }
    }

}
}


#########################################################################
#        C H E C K   T H E    A T T R I B U T E   --   O P E N    C O N T E X T   V E R S I O N 
#########################################################################
# second and main stage of processing attributes
#

###  a note on open contexts: how to process?  Imagine.  a new
###  attribute came.  do find_context_for_attribute( $context ); If
###  something found, go there, strip the prefix and go on.  If not,
###  check if there is a matching prefix in the attribute.  If there
###  is, close current context, until we are there.  Then ...  ?

###   probably the above is incorrect.  Let's make some *contexts*
###   open, not the whole environment.  Then we will first check if
###   there is an attribute like $the_attribute in the current
###   context.  If there is, take it and that's it.  Otherwise, check
###   if there is any prefix defined and if the_attribute matches it.
###   And check every of the currently defined prefixes.  If it does
###   match, then just close current context until we reach the
###   best-matching one.

#########################################################################

sub check_the_attribute_in_open_context {


}



#########################################################################
# SUB   F I N D   C O N T E X T   F O R   A T T R I B U T E
#########################################################################
#
# Look for an attribute in current and previous contexts
#

sub find_context_for_attribute {
    my $context = shift;
    my $iter = $#open_context_names_stack;

    while ( $iter > -1 ) {

        $prefix = $open_prefixes_stack[$iter];

	notice "checking context '$context->{SHOWNAME}' for attribute '$the_attribute'"
	    if $notices;

	my $prefix_length = length ( $prefix );
	my $attr_prefix = substr( $the_attribute, 0, $prefix_length );
	if ( $attr_prefix eq $prefix ) { 

	    $attribute_short = substr( $the_attribute, $prefix_length );

	    if ( defined ( $context ->{$attribute_short} )) {
		return $attr_prefix;

	    } elsif ( $attribute_short =~ /^x\-[a-z]/ ) {
		$X = 1;
		return $attr_prefix;
	    }
	}

	
	if ( ($the_attribute=~ /^x-/i) ) {
	    return '' if ($current_context_name ne 'zero');
	}

	$iter--;
	my $c_name = $open_context_names_stack[$iter] ;
	
#	warn "going to check context $c_name"
#	    if $DEBUG;

	if ( not defined $c_name ) { 
	    die " BAD \$iter: $iter $#open_context_names_stack ";
	}
	my $c = $specification->context( $c_name ); 
	if ( not defined $c ) {
	    die " BAD context name: $c_name";
	}
	$context = $c;

    }
    warn "attribute $the_attribute wasn't found"
	if $DEBUG ;
    return undef;
}



#########################################################################
#   C H E C K   T H E   A T T R I B U T E    V A L U E
#########################################################################

sub check_the_attribute_value {

    my $original_value = $value;
    my $value_is_bad = 0;
    my $ignore_attribute = 0;

    $attribute_remembered = 0; 
    $attribute_is_bad = 0;

    my $can_attribute_be_ignored = 0 ;
    my $show_errors_as_warnings  = 1 ;
    
    my $error_level;  ## default

    my $key_attr = $attr_specification->{key};
    my $req_attr = $attr_specification->{min};

    if ( $key_attr or $req_attr ) {
	$can_attribute_be_ignored = 0;
	$error_level = 'error';
    } else {
	$can_attribute_be_ignored = 1;
	$error_level = 'warning';
    }


    my @MESSAGES = ();

    my $type = $attr_specification->{'type'};
    my $subtype = $attr_specification->{'subtype'};


    my $type_spec;  ###  a reference to the type structure

    if ( not length ( $value ) ) {    ###  empty string 

	if ( $can_attribute_be_ignored ) {
	    $ignore_attribute = 1;

	} elsif ( $key_attr ) {
	    push @MESSAGES, 
	    [ "Key attribute '$the_attribute' has an empty value",
	      'warning' ];
	    $ignore_attribute = 1;

	} elsif ( $req_attr ) {
	    push @MESSAGES, 
	    [ "Required attribute '$the_attribute' has an empty value",
	      $error_level ];
	}

    } elsif ( (defined $type) 
	      and ( defined ($type_spec = $specification->type($type) ) ) 
	      and ( keys %$type_spec ) 
	      ) {
	
        ###  only if the attribute is a key attribute or a required attribute,
        ###  it's errorneous value will generate an error,
        ###  otherwise it will only generate a warning, 
        ###  and it will be ignored

	my $t;
        if ( defined ($t = $type_spec->{'check-regex'}) ) {
            if ( $value !~ /$t/ix ) {

		push @MESSAGES, 
		[ "Invalid value '$value' of type <$type> (attribute '$the_attribute', regex)",
		  $error_level ];

		if( $can_attribute_be_ignored ) {
		    $ignore_attribute = 1;
		}
            }
        }

        if ( defined $type_spec->{'check-eval'}) {
#        if ( 0 ) {
	    
	    my $check_func_ref = $type_spec->{'compiled-check-eval'} ;
#	    $ReDIF::Parser::Special::evaluation = $type_spec->{'check-eval'} ;
	    $ReDIF::Parser::Special::value = $value;
	    @ReDIF::Parser::Special::ERRORS   = ();
	    @ReDIF::Parser::Special::WARNINGS = ();
	    my $errors   = \@ReDIF::Parser::Special::ERRORS;
	    my $warnings = \@ReDIF::Parser::Special::WARNINGS;
	    
#	    my $result = 1;
	    my $result = &$check_func_ref;
	    $value = $ReDIF::Parser::Special::value;

#	    { 
#		package ReDIF::Parser::Special; 
#		$result = eval $evaluation;     ###  THE MEMORY LEAK SOURCE! HAHAHA!  :-)
#            }
#	    my $result = $ReDIF::Parser::Special::result;

	    if( 0 ) {
		warn "error at the 'check-eval' section of redif.spec,"
		    . " datatype: $type ($@)";
		
	    } else {

		###  main questions: 
		###    is there is a usable value?
		###    what messages should be displayed to the rech user?
		###    consequently, is the template still valid ?

		###  what if we accept the following: 
		###    bad value should generate an error in eval-check 
		###    or return back a false value.
		###    that will invalidate the template only if the attribute
		###    can not be ignored.  
		###    Otherwise the error messages should be converted 
		###    to warnings.
		###    if the evaluation returned true, but some errors as well,
		###    and we can ignore, we convert errors to warning and
		###    use the value
		###    if the evaluation returned true, and some errors as well,
		###    but we can't ignore, we issue an error and thus
		###    invalidate the template

		if ( not $result ) {
		    if( $can_attribute_be_ignored ) {
			$ignore_attribute =1;
		    } else {
			$show_errors_as_warnings = 0;
		    }
		    $value = '';
		} elsif( $result and scalar @$errors ) {
		    if( $can_attribute_be_ignored ) {
			$ignore_attribute =1;
		    } else {
			$show_errors_as_warnings = 0;
			$value_is_bad = 1;
			$value = '';
		    }

		} else {
		    my $value_is = 'good';
		}
		
		if( not $result and not scalar @$errors ) {
		    push @$errors, 
		    "Invalid value '$original_value' of type <$type> (attribute '$the_attribute', eval)";
		}

		my $mtype = ( $show_errors_as_warnings ) ? "warning" : "error" ;
		foreach my $er ( @$errors ) {
		    push @MESSAGES,  [ $er,  $mtype ];
		}

		foreach my $er ( @$warnings ) {
		    push @MESSAGES,  [ $er,  'warning' ];
		}
	    }
	}

    }

    ###  don't remember errorneous attribute, if it's just a warning
    if ( $ignore_attribute ) {
	$attribute_remembered = 1;
    }
    ###  [Dec-99 fix - end]

    ###  remember attribute

    remember_attribute() unless $attribute_remembered ;
    
    my %level = ( 'error' => 3, 
		  'warning' => 2 );

    foreach my $mess ( @MESSAGES ) {
	my $text = $mess->[0];
	my $l    = $mess->[1];
	$l       = $level{$l};

	message( $text, $l );
    }

}



#########################################################################
# SUB  R E M E M B E R    A T T R I B U T E     (INCLUDE_ATTRLINE)
#########################################################################
#
sub remember_attribute {

    return if $attribute_remembered;

    ### UNICODE

    local ( $value ) = $value;

    if ( $OUTPUT_ENCODING eq 'latin1' ) {
	if ( has_non_latin1_unicode( $value ) ) { 
	    if ( $TEMPLATE_EXPRESSIBLE_IN_LATIN1 ) {
		$TEMPLATE_EXPRESSIBLE_IN_LATIN1 = 0;
	    }
	} else {
	    $value = latin1_from_utf8 ( $value );
	}
    } else {
    }

    if ( $Options->{'build_good_template_text'} ) {
	if ( $value ne ''
	     or $Options->{'build_good_template_text_include_empty'} ) {

	    my $v = get_non_utf8_value( $value ); 
	    $v =~ s/\n/\n /g;
	    $good_template_text .= "$the_attribute: $v\n" ;
	}
    }
    
    add_attribute_to_hash( );

    $attribute_remembered = 1;

}




##########################################################################
# add attribute's data to the the record object
#
sub add_attribute_to_hash {

#    notice "scalar-value add_attribute_to_hash";
    if ( defined $attribute_short and 
	 defined $current_record_object->{$attribute_short} 
	 and not $template_start_attributes->{$the_attribute} ) {
#	 and $attribute_short ne 'template-type') {
	$current_record_object->{$attribute_short} .= "; $value";
    } else {
	$current_record_object->{$attribute_short} = $value;
    }
}

##########################################################################
# add attributes data to the the record object, but now fixed

# use Carp qw(cluck);

sub multiple_values_bug_fix {
#    cluck;
    undef &ReDIF::Parser::Core::add_attribute_to_hash;
    eval q!
	sub ReDIF::Parser::Core::add_attribute_to_hash {
#	    notice "multi-value add_attribute_to_hash";
	    if ( defined $current_record_object->{$attribute_short} 
#		 and $attribute_short ne 'template-type'
		 ) {
		push ( @{$current_record_object->{$attribute_short}}, $value ) ; 
	    } else {
		$current_record_object->{$attribute_short} = [ $value ]; 
	    }
	}
    !;
    die "$@" if $@;
    $multiple_values_template_hash = 1;
}


sub scalar_values_template_hash {
    undef &add_attribute_to_hash;
    eval q!
	sub add_attribute_to_hash {

	  if ( defined $attribute_short and 
	       defined $current_record_object->{$attribute_short} 
	       and not $template_start_attributes->{$the_attribute} ) {
	    $current_record_object->{$attribute_short} .= "; $value";
	  } else {
	    $current_record_object->{$attribute_short} = $value;
	  }
	}
    !;
    die "$@" if $@;
    $multiple_values_template_hash = 1;
}


#########################################################################
#    O P E N    C O N T E X T 
#########################################################################

sub open_context {

    my ($context, $prefix) = @_ ;

    my $new_context_showname = $context->{SHOWNAME};
    my $new_context_name     = $context->{NAME};                                                                    
    notice "Opening context <$new_context_showname>"
	if $notices;

    push @open_context_names_stack, $new_context_name;

    if ( defined $prefix  and  defined $open_prefixes_stack[0] ) {
       push @open_prefixes_stack, $open_prefixes_stack[-1] . $prefix;
    } else {
       push @open_prefixes_stack, $open_prefixes_stack[-1];
    }

    $current_context_object = $context;
    current_context_changed( );


    my $keyName = $prefix;            ###  $keyName = cluster name, hash element
    chop $keyName if defined $keyName; ##  strip a dash '-' at the end.

    $current_prefix =  $open_prefixes_stack[-1];

    if ( $current_prefix ne '' ) {

#	if( $Options->{'build_template_hash'} ) {
	
	    my $new_record = {};

	    $new_record->{'TYPE'}   = $current_context_name;
	    $new_record->{'PREFIX'} = $current_prefix;
	
	    if ( not exists $current_record_object->{$keyName} ) {
		$current_record_object->{$keyName} = [ $new_record ];
	    } else {
		my $array_ref = $current_record_object->{$keyName};
		push @$array_ref, $new_record;
	    }
	    
	    push @open_records_stack, $current_record_object;
	    $current_record_object = $new_record;
#	}
    }

}

#########################################################################
#     C L O S E    C U R R E N T    C O N T E X T
#########################################################################

sub close_current_context {
    
    my $context = $current_context_object;


    notice "Closing context <$current_context_showname>"
	if $notices;


    ############################
    # Resetting counters
    #
    my $atr;
    my ( $_min, $_cur ) ;
    foreach $atr (keys %$context) {

        if ( $atr !~ /[A-Z]/ ) {

	    my $this_attribute_short_name = $atr;
	    my $this_attribute_definition = $context->{$atr};

	    $_min = $this_attribute_definition->{min};

	    ###  optimization
	    if( not defined $_min ) {
		$context->{$atr}->{'COUNT'}{'CUR'}= 0;
		next;
	    }

	    $_cur = $this_attribute_definition->{COUNT}{CUR};

            if ( defined $_min 
		 and defined $_cur 
		 and ( $_cur < $_min) ) {
                error 
   "Required attribute '$atr' is absent in $context->{DESCRIPTION}" ;
            }
            $context->{$atr}->{'COUNT'}{'CUR'}= 0;
        }
    }

    $context -> {'OK'} = 0;
    if ( $current_context_name =~ /^template\d?/ ) {
        before_template_close( );
    }

    if( $context->{POST_RULES} ) {
    
#	warn "A context has POST_RULES ($context->{SHOWNAME})";

	my $rules = $context->{POST_RULES};
	foreach my $r ( @$rules ) { 
	    my $res = check_current_record_object_against_a_rule( $r );
	    if( not $res ) {
		error 
"$context->{DESCRIPTION} does not satisfy a post-checking rule $r->{DESCRIPTION}";
	    }
	}
	if( scalar @$rules ) {
	    warn "the context checked against a postprocessing"
		if $DEBUG;
	}
    } else {
#	warn "the context $context->{SHOWNAME} had no postprocessing"
#	    if $DEBUG;
	    ;
    }


#    if( $Options->{'build_template_hash'} ) {
	if ( scalar @open_records_stack ) {
	    $current_record_object =  pop @open_records_stack ;
	}
#    }

    $#open_context_names_stack--;
    $#open_prefixes_stack--;



    $current_context_object = 
	$specification -> context( $open_context_names_stack[-1] ) ;
    current_context_changed( );

    1;
}


sub current_context_changed {

    my $context = $current_context_object;
    
    $current_context_showname = $context->{SHOWNAME};
    $current_context_name     = $context->{NAME};
    $current_prefix           = $open_prefixes_stack[-1];

}



#########################################################################

sub check_current_record_object_against_a_rule {
    my $rule = shift;


    $ReDIF::Parser::Special::object   = $current_record_object;
    @ReDIF::Parser::Special::ERRORS   = ();
    @ReDIF::Parser::Special::WARNINGS = ();
    my $errors   = \@ReDIF::Parser::Special::ERRORS;
    my $warnings = \@ReDIF::Parser::Special::WARNINGS;
    
    my $result = &$rule;

    if( 0 ) {
	warn "error at the context postprocessing from redif.spec,"
	    . " context: $current_context_name ($@)";
	return 0;
	
    } else {
	
	foreach my $er ( @$errors ) {
	    message( $er, 3, 1 );
#	    warn "postproc error $er";
	}

###  it looks like post-processing nice reporting now works, but nasty
###  diagnostics are still there and I'm still not sure that we
###  actually need that type of stuff...

	
	foreach my $t ( @$warnings ) {
	    message( $t, 2, 1 );
#	    warn "postproc warning $t";
	}
    }

    return 1;
}


#########################################################################

sub bad_unknown_attribute {

    my $where = $specification->{attribute_list}-> {$the_attribute} ;
    if ( $where ) {
        error "Attribute '$the_attribute' is wrong or misplaced.".
            " Could be correct if used in template of type $where.";
    } else {
        error "Invalid (unknown) attribute '$the_attribute'";
    }
}

#########################################################################

sub eof_reached {
    generalclose ();
}

sub generalclose {

    close_current_template();

#    if( $OUTPUT->messages_count () ) {
#	$OUTPUT->print( );
#	$OUTPUT->clear( );
#    }
}


##########################################################################

sub before_template_close {

}

#########################################################################

sub before_template_start {

    if( $Options->{HashT} ) {
#	undef $the_record_object;
	%::HashT = ();
	$the_record_object = \%::HashT;
    } else {
#	undef $the_record_object;
	$the_record_object = {};
    }

#    $OUTPUT->clear();
    $good_template_text = '';

    #  a local template-hash reference
    $current_record_object = $the_record_object;  

    @open_records_stack = ( );

    $the_record_object->{'FILENAME'}  = $file;
    $the_record_object->{'STARTFPOS'} = $input_file_position;
    $the_record_object->{'START_LINE_NUMBER'} = $line_number;
    $Result = 0;

    $TEMPLATE_EXPRESSIBLE_IN_LATIN1 = 1;   ###  UNICODE

}


#END {
##    msg "END block of 'context' invocated",0;
#    generalclose( );
#}





#########################################################################

sub update_statistics {

#
# Statistics collecting 
#
# previously, this function was used to collect overall statistics of
# appeared attributes.  Now it only checks for context's allowed upper
# limit for attribute occurences.
#
    if ( $value =~ /^\s*$/ ) { 
#	$attributesempty++;
	return; }
    
    my $at_stat = $attr_specification->{'COUNT'};
#    $at_stat->{'ALL'}++;
    $at_stat->{'CUR'}++;

    if ( not $attr_specification->{'key'} 
	 and $attr_specification->{'max'} 
	 and ( $attr_specification->{'max'} < $at_stat->{'CUR'} ) ) {
	error "You cannot repeat this attribute ('$the_attribute') here";
    }
    

#  May be this can be made a bit simplier, if we only 
#  distinct repeatable and non-repeatable
#  attributes

#    if ( (not defined $at_stat->{'MAX'} ) or 
#            ($at_stat->{'CUR'} > $at_stat->{'MAX'}) ) {
#        $at_stat->{'MAX'} = $at_stat->{'CUR'};
#    }

}




1;

__END__



