cldb.pl fixes

#	$RCSfile: cldb.pl,v $
#	$Revision: 1.6 $
#	$Author: marten $
#	$Date: 1994/11/17 13:43:57 $

# This module contains all routines for classless indexing and lookups
# and some routines to do conversions here and there

require "misc.pl";
require "defines.pl";
require "time.pl";

# This is triple booo!!!! Change this !!!!

# $OVERFLOWDIR = "/ncc/nccfs3/cldb/data";

#
# convertonormal($cla)
#
# converts a integer prefix/length internal structure to a readable
# quad prefix/len string

sub converttonormal {
    local($cla) = @_;

    local($int, $len) = split(/\//, $cla);
    return &int2quad($int)."/$len";
}

#
# cla2unikey($cla)
#
# gives back an array of unique keys into the database that match this
# cla. Basically it will extract all the "O" values for $mspnxl{$cla} and
# put them into an array.

sub cla2unikey {
    local($cla) = @_;
    local(@result) = ();

    local($cla2tmp);
    &getmspnxl($cla, *cla2tmp);

    while ($cla2tmp =~ s/^O([^,]+)//) {
	next if $1 =~ /DUMMY/;
	@result = (@result, $1);
    }

    return @result;
}

#
# getmspnxl($index)
#
# gets the value (a string) for a certain index in the assoc array %mspnxl
# because of the overflow mechanism, this could be retrieved from a file
# or straight from the DBM file

sub getmspnxl {
    local($index, *value) = @_;
    if ($previous eq $index) {
    } else {
	$previous = $index;
    }

    &timer("getmspnxl", 1);

    $value = $mspnxl{$index};

    if ($value eq "ETOOBIG") {
	$value = "";
	local($filename) = &converttonormal($index);
	$filename =~ s/\//\./g;
	local($counter) = 0;
	while (!open(FILE, "$OVERFLOWPREFIX.$filename")) {
	    select(undef, undef, undef, 0.05);
	    $counter++;
	    if ($counter > 10) {
		die "major failure! cannot open $OVERFLOWPREFIX.$filename: $!";
	    }
	}
	sysread(FILE, $value, 1000000, 0);
	close(FILE);
    }

    &timer("getmspnxl", 0);

    return *value;
}

#
# setmspnxl($index, $value)
#
# sets the value for a certain index in assoc array %mspnxl. Because of
# the 1K max in DBM, the overflow mechanism must be used for large values
# In the overflow mechanism, whenever a file needs to be updated, a new
# file will be created, and renamed after. This is make the time the file
# is not available (for servers) as short as possible.

sub setmspnxl {
    local($index, *value, *addvalue) = @_;

    &timer("setmspnxl", 1);

    if (length($value) + length($addvalue) > 950) {
	if ($addvalue) {
	    $value .= ",$addvalue";
	}
	local($filename) = &converttonormal($index);
	$filename =~ s/\//\./g;
#	unlink("$OVERFLOWDIR/$filename.$CUROBJTYPE");

	# Create a new file with new values

        open(FILE, "+>$OVERFLOWPREFIX.$filename,")
	    || die "cannot open $filename: $!";
        syswrite(FILE, $value, length($value), 0);
        close(FILE);

	# Move the new file to the original.

	rename("$OVERFLOWPREFIX.$filename,",
	       "$OVERFLOWPREFIX.$filename");

        $mspnxl{$index} = "ETOOBIG";
    } else {
	if ($mspnxl{$index} eq "ETOOBIG") {
	    local($filename) = &converttonormal($index);
	    $filename =~ s/\//\./g;
	    unlink("$OVERFLOWPREFIX.$filename");
	}
	if ($addvalue || $value) {
	    if ($addvalue) {
		$mspnxl{$index} .= ",$addvalue";
	    } else {
		$mspnxl{$index} = $value;
	    }
	} else {
	    delete $mspnxl{$index};
	}
    }
    &timer("setmspnxl");
}

#
# old_to_new($oldnet)
#
# converts old style RIPE database network numbers (single classful net
# and classful ranges) to prefix/length format. Prefix/length is the
# internal representation used. Routine to convert a range into
# prefix/length is happily stolen from "aggis" by Dale Johnson, MERIT
# Thanks Dale ;-)

sub old_to_new {
    local($oldnet) = @_;
    local($len);
    local(@returnstring) = ();
    local($one_net);

    &timer("old_to_new", 1);

    # Conventional classful nets

    if ($oldnet =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
        if ($1 >= 192) {
            $len = 24;
	    $len = 32 if $4;
            $one_net =  0x00000100;
        } elsif ($1 >= 128) {
            $len = 16;
            $one_net = 0x00010000;
        } else {
            $len = 8;
            $one_net = 0x01000000;
        }
    }
    # Special case, it can happen that we got a hostaddress and mask
    # let's make sure we remove the mask when we return this.
    # this is for ifaddr in inet-rtr

    if ($oldnet =~ /(\d+\.\d+\.\d+\.\d+)\s+\d+\.\d+\.\d+\.\d+/) {
	return "$1/$len";
    }

    if ($oldnet !~ /\-/) {
	&timer("old_to_new");
	return "$oldnet/$len";
    }

    # Now, we have a classful range, let's convert this into pref/len

    if ($oldnet =~ /^(\d+\.\d+\.\d+\.\d+)\s+\-\s+(\d+\.\d+\.\d+\.\d+)/) {
	local($begin) = &quad2int($1);
	local($end) = &quad2int($2);
	local($newbegin) = $begin;
	while ($newbegin <= $end) {
	    for ($pwr=1; $pwr<24; $pwr++) {
		$pwr2 = 2 ** $pwr;
		$thisend = $newbegin + ($pwr2-1)*$one_net;
		return @returnstring if !$newbegin;
		if (($thisend > $end) ||
		    $newbegin != ($newbegin & $masks[$len-$pwr])) {
		    $pwr--;
		    $giveback = sprintf("%s/%d", &int2quad($newbegin),
					$len-$pwr);
		    @returnstring = (@returnstring, $giveback);
		    $newbegin = $newbegin + $one_net * 2**$pwr;
		    last;
		}
	    }
	}
    }
    &timer("old_to_new");
    return @returnstring;
}

#
# findlsps($cla, $recursive)
#
# Find the list of less specifics for prefix $cla. If the recursion
# flag is set, all less specifics (lsps) are returned, otherwise only
# the first less specific. It is not a recursive routine, but oh well.

sub findlsps {
    local($cla, $recurse) = @_;
    local($prefix, $len) = split(/\//, $cla);
    local($returnlist) = "";
    local($ii);

    for ($ii=$len;$ii>=0;$ii--) {
        local($newcla) = ($prefix & $masks[$ii]);
	local($tmp);
	&getmspnxl("$newcla/$ii", *tmp);
        if ($tmp) {
            if ($recurse) {
                if ($returnlist) {
                    $returnlist .= ",$newcla/$ii";
                } else {
                    $returnlist = "$newcla/$ii";
                }
            }
            else {
                return "$newcla/$ii";
            }
        }
    }
    return $returnlist;
}

#
# findmsps($cla, $orig, $first, $nonrecurse)
#
# routine to find all more specifics of a certain classless address cla.
# Because of recursion, it needs to remember the very first $cla it
# is called with, which stays in $orig. This is needed to check whether
# all found more specifics really are more specific. By default recursion
# is on, it will try and find all more specifics.

sub findmsps {
    local($cla, $orig, $first, $nonrecurse) = @_;
    local($j);
    local($msps) = "";

    # Look up first less specific when the requested $cla does not
    # exist itself, and use that to find all more specifics.

    local($tmp);
    &getmspnxl($orig, *tmp);

    # Now, if this $cla does not exist itself, we can do two things,
    # - we can step one level back, and check all them (painful if
    #   you have to step back to 0/0)
    # - allow only more specifics of prefixes that are actually
    #   in the database, return nothing if the prefix in the DB
    #   does not exist.

    # If you have indexed with priming on, the first is no problem.
    # If you have indexed with priming off, the first may take CPU....

    # This implements the first solution

    if (!$tmp && $first) {
        $cla = (split(/\,/, &findlsps($orig)))[0];
   }

    # And this the second solution

#    if (!$tmp && $first) {
#	return $msps;
#    }

    $tmp="";
    &getmspnxl($cla, *tmp);
    foreach (split(/,/, $tmp)) {
	local($tmp);
	&getmspnxl($_, *tmp);
        if ($tmp) {
            local($p1, $l1) = split(/\//, $_);
            local($p2, $l2) = split(/\//, $orig);
            if (($p1 & $masks[$l2]) == ($p2 & $masks[$l2])) {
		if ($nonrecurse) {
                    $msps .= "$_,";
                } else {
                    $msps .= $_ . "," . &findmsps($_, $orig,0,0);
                }
            }
        }
    }
    $msps;
}

#
# givemsps($string, $cla)
#
# Give all more specifics of $cla that can be found in $string. I think this
# can also be done by findmsps, but I'll keep it in here for now. Only
# needed for insertations right now. Returns a sub-string will all more
# specifics of $cla. This is a costly operations, and should only be done
# for one-off insertations (like normal updates). Indexing a whole (locked)
# file should not use this, the "to be inserted" cla's should be presorted.

sub givemsps {
    local(*string, $cla) = @_;
    local($returnstring) = "";
#    return $returnstring;

    &timer("givemsps", 1);
    local($pref, $len) = split(/\//, $cla);
    foreach (split(/,/, $string)) {
        next if $_ =~ /^O|^start$/;
        local($tmppref, $tmplen) = split(/\//, $_);
	next if $tmplen <= $len;
        if (($tmppref & $masks[$len]) == $pref) {
            if ($returnstring) {
                $returnstring .= ",".$_;
            } else {
                $returnstring = $_;
            }
        }
    }
    &timer("givemsps");
    return $returnstring;
}

#
# addtomspnxl($index, $value)
#
# Adds $value to the current value of $mspnxl{$index}. It is a wrapper
# for setmspnxl

sub addtomspnxl {
    local($index, *value) = @_;
    &timer("addtomspnxl", 1);

    local($addtotmp);
    &getmspnxl($index, *addtotmp);

    if ($addtotmp) {
        &setmspnxl($index, *addtotmp, *value);
    } else {
        &setmspnxl($index, *value);
    }
    &timer("addtomspnxl");
}

#
# deletefrommspnxl($index,$value)
#
# Deletes $value from the current value of $mspnxl{$index}. Basically
# another wrapper for setmspnxl

sub deletefrommspnxl {
    local($index, *value) = @_;
    local($j);

    local($deletetmp);
    &getmspnxl($index, *deletetmp);

    foreach $j (split(/,/, $value)) {
	if ($deletetmp =~ s/^$j$//g) {}
	elsif ($deletetmp =~ s/^$j,//g) {}
	elsif ($deletetmp =~ s/,$j,/,/g) {}
	elsif ($deletetmp =~ s/,$j$//g) {}
    }

    &setmspnxl($index, *deletetmp);
}

#
# inscla($cla, $offset)
#
# Insert classless address $cla, which has an offset in the database
# of $offset, into the tree structure

# ! New version that does not store offsets but references to unique
# ! keys, which makes the lookup indirect, but makes the classless
# ! index independent of the offsets and thus the clean
# 
# Extra flag mspscheck says whether or not a check should be made
# for existing more specifics. When using netdbm, they are presorted
# and do not have to be msp-checked. For normal insertions, they
# should be checked. The reason this is optional is because givemsps
# can be quite costly in time....

sub inscla {
#    local($cla, $offset, $mspscheck) = @_;
    local($cla, $uniquekey, $mspscheck) = @_;
    local($j);
    local($p);

    if (!$mspnxl{"0/0"}) {
	$mspnxl{"0/0"} = "start";
    }

    print STDERR "inscla($cla) called\n" if $debug;

    local($prefix, $len) = split(/\//, $cla);

    for ($p=$len;$p>=0;$p--) {
        local($newcla) = ($prefix & $masks[$p]);
	local($tmp2);
	&getmspnxl("$newcla/$p", *tmp2);
        if ($tmp2) {
	    local($tmp);
            &getmspnxl($cla, *tmp);
            if (!$tmp) {
                local($tmp4) = "O$uniquekey";
                &setmspnxl($cla, *tmp4);
                &addtomspnxl("$newcla/$p", *cla);
            } else {
                local($tmp) = "O$uniquekey,$tmp";
                &setmspnxl($cla, *tmp);
            }
	    if ($mspscheck) {
		local($msps) = &givemsps(*tmp2, $cla);
		&addtomspnxl($cla, *msps);
		&deletefrommspnxl("$newcla/$p", *msps);
	    }
            $p=0;
        }
    }
}

#
# delcla($cla)
#
# Delete a classless address from the internal tree structure

sub delcla {
    local($cla) = @_;
    &timer("delcla",1);
    local($q);

    local($prefix, $len) = split(/\//, $cla);
    for ($q=$len-1;$q>=0;$q--) {
        local($newcla) = ($prefix & $masks[$q]);
	local($tmp2);
	&getmspnxl("$newcla/$q", *tmp2);
        if ($tmp2) {
            &deletefrommspnxl("$newcla/$q", *cla);
            local($tmp);
	    &getmspnxl($cla, *tmp);
            if ($tmp) {
		local($nothing);
		$tmp =~ s/^[^,]+[,]*//;
                &addtomspnxl("$newcla/$q", *tmp) if ($tmp ne "");
                &setmspnxl($cla, *nothing, *nothing);
            }
	    $q = 0;
        }
    }
    &timer("delcla");
}



-------- Logged at  Thu Nov 17 14:45:08 MET 1994  ---------