#! /local/bin/perl 

######################################################################
# $Header: /loc/adm/slink-1.0/src/slink-5.0/Slink/RCS/MapHash.pm,v 5.0 1996/05/13 17:14:27 couch Exp $
#  MapHash.pm: maintain internal mapping tables 
#  Revision 5.0
#  by
#  Alva L. Couch,                       
#  Associate Prof. of EE/CS          
#  Department of EE/CS             
#  Tufts University,            
#  Medford, Massachusetts, 02155.
#  couch@cs.tufts.edu
#
#  Copyright (C) 1996 by Alva L. Couch 
#
#  This file is part of SLINK
#
#  SLINK is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2, or (at your option)
#  any later version.
#
#  SLINK is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with GNU CC; see the file COPYING.  If not, write to
#  the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
######################################################################

######################################################################
#  mapping of operations for error checking 
#  internally, a link is a list of all values it took during this run.
#    The internal structure of a map is 
#    %map -assoc-> [[pop,pval],[[op1,va1],...[opn,van]]]
#  externally, a link is just the last value it took. 
#  Slink::MapHash::writer strips off all the other values, 
#  after Slink::MapHash::check reports errors in the configuration file. 
######################################################################

package Slink::MapHash; 
require 5.001;
require Exporter;
use Cwd;
use Slink::Logger; 
use strict;

BEGIN { 
    @Slink::MapHash::ISA = qw(Exporter);
    @Slink::MapHash::EXPORT = ();
    @Slink::MapHash::EXPORT_OK 
	= (qw(wasmapped mapped source),
	   qw(add del reader writer check close));
}

# a new map is an empty assoclist unless one specifies a filename, 
# in which case the map is read from that filename. 

sub new { 
    my ($mod,$file,$logger) = @_; 
    my $temp = bless {}; 
    $temp->reader($file,$logger) if defined $file;
    return $temp; 
}

# check history file for mappings

sub wasmapped {
    my($this,$op,$sourc,$image) = @_; 
    my $entry = $this->source($image); 
    return 0 if ! defined $entry; 
    my($history) = $entry->[1]; 
    my $i; 
    for ($i=0; 
	 $i<@$history 
      && ((defined $op && $history->[$i]->[0] ne $op)
       || (defined $sourc && $history->[$i]->[1] ne $sourc)); 
	 $i++) { }
    return 1 if ($i<@$history);
    return 0; 
}

# return 1 if the given link is mapped, 0 otherwise
# check only things that should be so now. 

sub mapped { 
    my($this, $op, $sourc, $image) = @_; 
    my $state = $this->source($image); 
    return 0 if ! defined $state; 
    return 1 if (! defined $op || $state->[0] eq $op)
	     && (! defined $sourc || $state->[1] eq $sourc); 
    return 0; 
}

# return the mapping for a thing or undef if not defined
# return value is a reference 

sub source { 
    my ($this,$image) = @_; 
    my $entry = $this->{$image}; 
    return undef if ! defined $entry; 
    return $entry->[0]; 
}

# add a link to a map; make the added link
# the first one in the link list, and 
# eliminate duplicates. 

sub add {
    my($this,$op,$sourc,$image) = @_; 
    if (! defined $this->{$image}) {
	$this->{$image} = [[$op,$sourc], [[$op,$sourc]]]; 
    } else {
	my($record) = $this->{$image}; 
	# update current value
        $record->[0] = [$op,$sourc]; 
	# new value is last value of history
        my($hist) = $record->[1]; 
        # remove new value from list if it's there
        my ($i); 
        for ($i=0; $i<=$#$hist; $i++) { 
	    if ($hist->[$i]->[0] eq $op && $hist->[$i]->[1] eq $sourc) { 
		splice(@$hist,$i,1); 
		redo if $i<=$#$hist; 
	    }
	}
	unshift(@$hist,[$op,$sourc]); 
    }
}

# delete a mapped link from the link database

sub del {
    my($this,$image) = @_; 
    my($record) = $this->{$image}; 
    $record->[0] = undef if defined $record;
}

# write a map to a file. 
# only write principal sources, ignoring other sources
# that may have been used during a link run. 

sub writer {
    my($this,$file) = @_; 
    open(MAP,">$file") 
	|| die ("can't write map into $file: $!\n"); 
    my ($key,$value); 
    while (($key,$value) = each %$this) {
        print MAP "$key -> $value->[0]->[0] $value->[0]->[1]\n" 
	    if defined $value->[0]; 
    }
    close MAP; 
}

# read a map for interim checking of sources
# include old map sources if they're in the current map. 

sub reader {
    my ($this,$file,$logger) = @_; 
    %$this = (); 
    if (! -r $file) {
	$logger->error("can't read map from $file"); 
	return $this; 
    }
    open(MAP,"<$file") 
	|| die ("can't read map from $file: $!\n"); 
    while (<MAP>) {
	next if /^[ \t]*$/ || /^[ \t]*#/; 
	my ($key,$dummy,$op,$value) = split; 
	$this->{$key} = [[$op,$value],[[$op,$value]]]; 
    }
    close(MAP); 
    return $this; 
}

# check a map for duplicate sources

sub check {
    my ($this,$logger) = @_; 
    my (@dups) = (); 
    my ($key,$value); 
    while (($key,$value) = each %$this) {
	my($valref) = $value->[1]; 
	if (@$valref>1) {
	    $logger->error_start("$key has multiple sources:\n"); 
	    foreach (@$valref) {
		$logger->error_part(" -> $_->[0] $_->[1]\n"); 
	    }
	    $logger->error_end(); 
	    push(@dups,$key); 
	}
    }
    return @dups; 
}

# close a map by writing it out and checking for errors. 

sub close {
    my($this,$file,$logger) = @_; 
    $this->writer($file) if @_ > 1;	# write out the map if given a filename
    my @dups = $this->check($logger); 	# check if map is multiple or not
    my $dups = @dups; 			# number of keys
    if ($dups > 0) { 
	$logger->error("$dups duplicate sources found!"); 
	return 0; 
    }
    return 1; 
}

# copy a map into a new disjoint assoc. array. 

sub copy { 
    my ($this) = @_;
    my $newref = bless {}; 
    my ($key,$value) ; 
    while (($key,$value) = each %$this) {
	$newref->{$key} = $value; 
    }
    return $newref; 
}

1;