RIPE RR SW fix: cldb.pl
Marten Terpstra
Tue Dec 6 02:32:47 CET 1994
Oops sorry folks, forgot you all ;-(
[ Put this module in place of <dbhome>/src/cldb.pl, go up to <dbhome>
and run a "make". "make install" is not needed - MT ]
# $RCSfile: cldb.pl,v $
# $Revision: 1.9 $
# $Author: marten $
# $Date: 1994/12/06 01:09:52 $
# 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;
$len = 32 if $4;
$one_net = 0x00010000;
} else {
$len = 8;
$len = 32 if $4;
$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;
}
}
}
#
# delfromcla($cla, $value)
# delete a specific string from a $cla value. Delete the complete $cla
# if the result is an empty reference.
sub delfromcla {
local($cla, $value) = @_;
local($tmp);
&getmspnxl($cla, *tmp);
if ($tmp){
if ($tmp =~ s/^O$value$//) {
&delcla($cla);
return;
} elsif ($tmp =~ s/^O$value,//) {}
elsif ($tmp =~ s/,O$value,/,/) {}
elsif ($tmp =~ s/,O$value$//) {}
}
&setmspnxl($cla, *tmp);
}
#
# 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 Wed Dec 21 20:11:42 MET 1994 ---------
[ rr-impl Archive ]