emutil.pm.in 10.8 KB
Newer Older
1 2 3
#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2000-2010 University of Utah and the Flux Group.
5 6 7 8 9 10 11
# All rights reserved.
#
# Utility routines for Emulab.
#
package emutil;
use strict;
use Exporter;
12
use SelfLoader;
13
use vars qw(@ISA @EXPORT);
14 15 16 17
@ISA = qw(Exporter SelfLoader);
@EXPORT = qw(TBDB_CHECKDBSLOT_NOFLAGS TBDB_CHECKDBSLOT_WARN
	     TBDB_CHECKDBSLOT_ERROR TBcheck_dbslot TBFieldErrorString
	     TBGetUniqueIndex ParRun);
18

19
use emdb;
20 21
use English;

22 23 24 25
#
# Support for checking field values against what is specified.
#
use vars qw(%DBFieldData $DBFieldErrstr);
26

27 28 29
%DBFieldData   = ();
$DBFieldErrstr = "";

30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
#
# A helper function for checking lossrates. Bad place for this, I know.
# Needs to be before the __DATA__ cause we used defined() on it. Sigh.
#
sub _checklossrate($)
{
    my ($token) = @_;

    return 1
	if ("$token" eq "0");

    # floating point, no exponent. Stole this out of the perl tutorial.
    if (! ($token =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+)([eE][+-]?\d+)?$/)) {
	$DBFieldErrstr = "Improper floating number";
	return 0;
    }
    if ($token > 1.0) {
	$DBFieldErrstr = "Too big; must be < 1.0";
	return 0;
    }
    if ($token < 0.0) {
	$DBFieldErrstr = "Too small; must be > 0.0";
	return 0;
    }
    if ($token > 0.0 && $token < 0.000001) {
	$DBFieldErrstr = "Too small; must be >= 0.000001";
	return 0;
    }
    return 1;
}

61
1;
62
@SELFLOADER_DATA@
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78

# Constants for checkslot code.
sub TBDB_CHECKDBSLOT_NOFLAGS()	{ 0x0; }
sub TBDB_CHECKDBSLOT_WARN()	{ 0x1; }
sub TBDB_CHECKDBSLOT_ERROR()	{ 0x2; }

sub TBFieldErrorString() { return $DBFieldErrstr; }

#
# Download all data from the DB and store in hash for latter access.
#
sub TBGrabFieldData()
{
    %DBFieldData = ();

    my $query_result =
79
	emdb::DBQueryFatal("select * from table_regex");
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181

    while (my %row = $query_result->fetchhash()) {
	my $table_name  = $row{"table_name"};
	my $column_name = $row{"column_name"};

	$DBFieldData{$table_name . ":" . $column_name} =
	    { "check"       => $row{"check"},
	      "check_type"  => $row{"check_type"},
	      "column_type" => $row{"column_type"},
	      "min"         => $row{"min"},
	      "max"         => $row{"max"}
	    };
    }
}

#
# Return the field data for a specific table/slot. If none, return the default
# entry.
#
# The top level entry defines some stuff that is not to be overidden by the
# redirected entries. For example, the top level entry is the only place we
# can specify a field is optional when inserting a record. We could do this
# with default entries in the DB table defintion, but I do not like that idea.
# The min/max lengths also override, unless they are both zero in which case
# let the first non-zero defs set them.
#
sub TBFieldData($$;$)
{
    my ($table, $column, $flag) = @_;
    my $toplevel;
    my $fielddata;

    if (! %DBFieldData) {
	TBGrabFieldData();
    }
    my $key = $table . ":" . $column;

    while (exists($DBFieldData{$key})) {
	$fielddata = $DBFieldData{$key};

	#
	# See if a redirect to another entry.
	#
	if ($fielddata->{"check_type"} eq "redirect") {
	    if (!defined($toplevel)) {
		$toplevel = $fielddata;
	    }

	    $key = $fielddata->{"check"};
#	    print STDERR "Redirecting to $key for $table/$column!\n";
	    next;
	}
	last;
    }
    # Resort to a default entry.
    if (!defined($fielddata)) {
	$DBFieldErrstr = "Error-checking pattern missing from the database";
	
	if (defined($flag)) {
	    if ($flag & TBDB_CHECKDBSLOT_WARN()) {
		print STDERR "*** $0:\n" .
		             "    WARNING: No slot data for $table/$column!\n";
	    }
	    return undef
		if ($flag & TBDB_CHECKDBSLOT_ERROR());
	}
	$fielddata = $DBFieldData{"default:default"};
    }
    # Return both entries.
    if (defined($toplevel) &&
	($toplevel->{"min"} || $toplevel->{"max"})) {
	return ($fielddata, $toplevel);
    }
    return ($fielddata);
}

#
# Generic wrapper to check a slot.
#
sub TBcheck_dbslot($$$;$)
{
    my ($token, $table, $column, $flag) = @_;
    
    $DBFieldErrstr = "Unknown Error";

    my ($fielddata,$toplevel) = TBFieldData($table, $column, $flag);

    return 0
	if (!defined($fielddata));

    my $check       = $fielddata->{"check"};
    my $check_type  = $fielddata->{"check_type"};
    my $column_type = $fielddata->{"column_type"};
    my $min         = (defined($toplevel) ?
		       $toplevel->{"min"} : $fielddata->{"min"});
    my $max         = (defined($toplevel) ?
		       $toplevel->{"max"} : $fielddata->{"max"});

#    print STDERR "Using $check/$check_type/$column_type/$min/$max for ".
#	"$table/$column\n";

    #
182
    # Functional checks partly implemented. Needs work.
183 184
    #
    if ($check_type eq "function") {
185 186 187 188 189 190
	if (defined(&$check)) {
	    my $func = \&$check;
	    return &$func($token);   
	}
	else {
	    die("*** $0:\n" .
191 192
		"    Functional DB check not implemented: ".
		"$table/$column/$check\n");
193
	}
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238
    }

    # Make sure the regex is anchored. Its a mistake not to be!
    $check = "^" . $check
	if (! ($check =~ /^\^/));

    $check = $check . "\$"
	if (! ($check =~ /\Q$/));

    # Check regex.
    if (! ("$token" =~ /$check/)) {
	$DBFieldErrstr = "Illegal Characters";
	return 0;
    }

    # Check min/max.
    if ($column_type eq "text") {
	my $len = length($token);

	# Any length is okay if no min or max. 
	return 1
	    if ((!($min || $max)) ||
		($len >= $min && $len <= $max));
	$DBFieldErrstr = "Too Short"
	    if ($min && $len < $min);
	$DBFieldErrstr = "Too Long"
	    if ($max && $len > $max);
    }
    elsif ($column_type eq "int" ||
	   $column_type eq "float") {
	# If both min/max are zero, then skip check; allow anything.
	return 1
	    if ((!($min || $max)) || ($token >= $min && $token <= $max));
	$DBFieldErrstr = "Too Small"
	    if ($min && $token < $min);
	$DBFieldErrstr = "Too Big"
	    if ($max && $token > $max);
    }
    else {
	die("*** $0:\n" .
	    "    Unrecognized column_type $column_type\n");
    }
    return 0;
}

239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
#
# Return a unique index from emulab_indicies for the indicated name.
# Updates the index to be, well, unique.
# Eats flaming death on error.
#
# WARNING: this will unlock all locked tables, be careful where you call it!
#
sub TBGetUniqueIndex($;$$)
{
    my ($name, $initval, $nolock) = @_;

    #
    # Lock the table to avoid conflict, but not if the caller already did it.
    #
    $nolock = 0
	if (!defined($nolock));
    
    DBQueryFatal("lock tables emulab_indicies write")
	if (!$nolock);

    my $query_result =
	DBQueryFatal("select idx from emulab_indicies ".
		     "where name='$name'");
    my ($curidx) = $query_result->fetchrow_array();
    if (!defined($curidx)) {
	$curidx = (defined($initval) ? $initval : 1);
    }
    my $nextidx = $curidx + 1;

    DBQueryFatal("replace into emulab_indicies (name, idx) ".
		 "values ('$name', $nextidx)");
    DBQueryFatal("unlock tables")
	if (!$nolock);

    return $curidx;
}

276 277 278 279 280 281 282 283 284 285 286 287 288
#
# A utility function for forking off a bunch of children and
# waiting for them.
#
# TODO: A fatal error will leave children. Need to catch that.
#
sub ParRun($$$@)
{
    my ($options, $pref, $function, @objects) = @_;
    my %children = ();
    my @results  = ();
    my $counter  = 0;
    my $signaled = 0;
289 290
    # We need this below.
    require event;
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358

    # options.
    my $maxchildren = 10;
    my $maxwaittime = 200;

    if (defined($options)) {
	$maxchildren = $options->{'maxchildren'}
	    if (exists($options->{'maxchildren'}));
	$maxwaittime = $options->{'maxwaittime'}
	    if (exists($options->{'maxwaittime'}));
    }

    #
    # Set up a signal handler in the parent to handle termination.
    #
    my $coderef = sub {
	my ($signame) = @_;

	print STDERR "Caught SIG${signame}! Killing parrun ...";

	$SIG{TERM} = 'IGNORE';
	$signaled = 1;

	foreach my $pid (keys(%children)) {
	    kill('TERM', $pid);
	}
	sleep(1);
    };
    local $SIG{QUIT} = $coderef;
    local $SIG{TERM} = $coderef;
    local $SIG{HUP}  = $coderef;
    local $SIG{INT}  = 'IGNORE';

    #
    # Initialize return.
    #
    for (my $i = 0; $i < scalar(@objects); $i++) {
	$results[$i] = -1;
    }

    while (@objects || keys(%children)) {
	#
	# Something to do and still have free slots.
	#
	if (@objects && keys(%children) < $maxchildren && !$signaled) {
	    # Space out the invocation of child processes a little.
	    sleep(1);
	    
	    #
	    # Run command in a child process, protected by an alarm to
	    # ensure that whatever happens is not hung up forever in
	    # some funky state.
	    #
	    my $object = shift(@objects);
	    my $syspid = fork();

	    if ($syspid) {
		#
		# Just keep track of it, we'll wait for it finish down below
		#
		$children{$syspid} = [$object, $counter, time()];
		$counter++;
	    }
	    else {
		$SIG{TERM} = 'DEFAULT';
		$SIG{QUIT} = 'DEFAULT';
		$SIG{HUP}  = 'DEFAULT';
		
359 360
		# So we get the event system fork too ...
		event::EventFork();
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
		exit(&$function($object));
	    }
	}
	elsif ($signaled) {
	    my $childpid   = wait();
	    my $exitstatus = $?;

	    if (exists($children{$childpid})) {
		delete($children{$childpid});
	    }
	}
	else {
	    #
	    # We have too many of the little rugrats, wait for one to die
	    #
	    #
	    # Set up a timer - we want to kill processes after they
	    # hit timeout, so we find the first one marked for death.
	    #
	    my $oldest;
	    my $oldestpid = 0;
	    my $oldestobj;
	    
	    while (my ($pid, $aref) = each %children) {
		my ($object, $which, $birthtime) = @$aref;

		if ((!$oldestpid) || ($birthtime < $oldest)) {
		    $oldest    = $birthtime;
		    $oldestpid = $pid;
		    $oldestobj = $object;
		}
	    }

	    #
	    # Sanity check
	    #
	    if (!$oldest) {
		print STDERR 
		    "*** ParRun: ".
		    "Uh oh, I have no children left, something is wrong!\n";
	    }

	    #
	    # If the oldest has already expired, just kill it off
	    # right now, and go back around the loop
	    #
	    my $now = time();
	    my $waittime = ($oldest + $maxwaittime) - time();

	    #
	    # Kill off the oldest if it gets too old while we are waiting.
	    #
	    my $childpid = -1;
	    my $exitstatus = -1;

	    eval {
		local $SIG{ALRM} = sub { die "alarm clock" };

		if ($waittime <= 0) {
		    print STDERR
			"*** ParRun: timeout waiting for child: $oldestpid\n";
		    kill("TERM", $oldestpid);
		}
		else {
		    alarm($waittime);
		}
		$childpid = wait();
		alarm 0;
		$exitstatus = $?;
	    };
	    if ($@) {
		die unless $@ =~ /alarm clock/;
		next;
	    }

	    #
	    # Another sanity check
	    #
	    if ($childpid < 0) {
		print STDERR
		    "*** ParRun:\n".
		    "wait() returned <0, something is wrong!\n";
		next;
	    }

	    #
	    # Look up to see what object this was associated with - if we
	    # do not know about this child, ignore it
	    #
	    my $aref = $children{$childpid};
	    next unless @$aref;	
	    my ($object, $which, $birthtime) = @$aref;
	    delete($children{$childpid});
	    $results[$which] = $exitstatus;
	}
    }
    @$pref = @results
	if (defined($pref));
    return -1
	if ($signaled);
    return 0;
}

464
# _Always_ make sure that this 1 is at the end of the file...
465
1;