
$_LIB_PATH= "$BASE/lib";

sub	proc_SEL_version {
$version= '$Id: PAL_runtime.pl,v 1.1 2007/03/23 20:08:01 drp Exp $';
}

#---------------- proc_SEL() is called by testgen to evaluate $list
#---------------------- at testgen runtime. The advantage is that
#---------------------- the list can contain $perl variables. On
#---------------------- the other hand, it is slower because list
#---------------------- needs be parsed every time.

#----------------- SELECTION LIST FORMAT ===> [$cmd[ list ]]
#-------------------* DONE :
#---------------------* $cmd= 'r' or nil: random selection list
#---------------------* $cmd= 's': random STRING selection list
#---------------------* $cmd= 'e', enumeration list
#---------------------* $cmd= 'l', return number of list elements
#---------------------* $cmd= 'D:{id}', define a random element index to be
#---------------------* 		used by 'U{id}'.
#---------------------* $cmd= 'U:{id}', instead of random choice, use the
#---------------------* 		element index used by SELECTION LIST
#---------------------* 		named 'D{id}'.
#---------------------* $cmd= '[dox]{n}': to print output in C's "%{n}[dox]"
#---------------------* 		format to be used with 'r' or 'e'.
#-------------------* TO DO :
#---------------------* $cmd= a number (n), select that n elements
#-----------------------      and apply enumeration or selection
#-----------------------      of permutation out of n elements.
#------------------------   $cmd= '1', same as nil
#------------------------   $cmd= '1e', same as nil
#---------------------* $cmd= 'a', all pertumation

sub	proc_SEL {
my($idx, $list, $cmd, $lineinfo)= @_;		#$indx for the list, and list itself
my($strList)= 0;

$list=~ s/\[\s*(.*)\s*\]$/$1/;			#for [ {list} ]: pass {list}
# $cmd=~ tr/[A-Z]/[a-z]/;			#translate cmd to the lower-case.

$LINE_INFO_FOR_ERR= $lineinfo;
if(   $cmd eq '') {	$cmd= 'r'; }
elsif($cmd =~ /s/) {	$strList= 1; }
# elsif($cmd =~ /s/) {	$cmd= 'r';	$strList= 1; }

my($result);
if( $list =~ /^\s*[\+\d-]/ && !$strList ) {
	$result= &num_list($idx, $list, $cmd);
}else{	$result= &str_list($idx, $list, $cmd); }

$result;
}

sub	str_list {		## take "{str} [:{weit}], {str} [:{weit}] ..."
my($idx, $list, $cmd)= @_;
my(@value, $i, $list_save);
my($elm_idx);
my($USE_WEIGHT)= 0;
local(@weight);


$list_save= $list;
$list=~ s/^\s*//;
while(1) {
   if($list =~ s/^([\&\$\w][\w_]*)//) {	#a unquoted identifier
	push(@value, $1);

# }elsif($list =~ s/^(\s*)(["'])([^\2]*)(\2)(\s*)//) {	#a '/" quoted string
# why can't I say [^\2]*, which means anything but not \2 ??

#   }elsif($list =~ s/^\s*(["'])([\$\w\s,.-]*)(\1)\s*//) { #a '/" quoted str
#	@value= (@value, $1 . $2 . $3);			#including enclosing "/'
#	# $list=~ s/$1$2$3$4$5//;

   }elsif($list =~ s/^'([^']*)'//) {		#a ' quoted str
	push(@value, "$1");				#including enclosing '

   }elsif($list =~ s/^"([^"]*)"//) {		#a " quoted str
	push(@value, "$1");				#including enclosing "

   }else{	& rt_error("illegal string list: [$list_save]"); }

##### process weight:
   $list =~ s/^\s*//;
   if($list =~ s/^:\s*([^,\s]+)\s*//) {
	push(@weight, eval $1);
	$USE_WEIGHT= 1;
   }else{
	push(@weight, 100);			#default weight 100
	}

   if($list eq '') {		last;
   }elsif($list !~ s/^,\s*//) {
	$list=~ /^(.)/;
	& rt_error(", expected but got `$1' in string list: [$list_save]");
	}
   } #end of while(1)

#-------------------------------$str_list_${idx} will be a $global variable
my($mark)= ($cmd =~ s/D:?(\w+)//) ? $1 : '';

if(    $cmd eq 'l')   {		return($#value + 1);
}elsif($cmd =~ s/U:?(\w+)//) {	$elm_idx= $DEF_ORDER{$1} % ($#value + 1);
}elsif($cmd =~ s/e//) {
	$USE_WEIGHT= 0;
	$elm_idx= eval("++ \$str_list_$idx") -1 ;
	if($elm_idx > $#value) { $elm_idx= 0;
				 eval("\$str_list_$idx= 1"); }
}else{
######### only this category allows weight !!
	$elm_idx= $USE_WEIGHT ?  & weighed_select( *weight ) 
			      :  int(rand( $#value+1 ));

# }elsif($cmd =~ s/r//) {		$elm_idx= int(rand($#value+1));
# }else {	& rt_error("No such string list command: $cmd");
	}


$DEF_ORDER{$mark}= $elm_idx	if($mark);

if($value[$elm_idx] =~ /^\&/) {
	eval '$result=' . $value[$elm_idx];
} else {
	$result= $value[$elm_idx];
	}

if($cmd=~/s(\d*)|(\d+)s/) {
	$result= sprintf("%$1s", $result);
	}
$result;
}

sub	weighed_select {	#Given weight array, return random idx selected
local(*W)= @_;
my($i, $sel);
for($i=1; $i<=$#W; ++$i) { $W[$i] += $W[$i-1]; }	#accumulate weight
$sel= int(rand( $W[$#W] ));
for($i=0; $i<=$#W; ++$i) {
	if($W[$i] > $sel) {
		$sel= $i;
		last;
		}
	}
$sel;
}

sub	num_list {			#take [-num .. +num2]
my($idx, $list, $cmd)= @_;
my(@range, @value, $list_save);
my($num_items)= 0;
my($lb, $ub, $i);
my($has_hex)=0;

$list_save= $list;
$list=~ s/\s//g;
while(1) {				#parse number list
    if($list =~ s/^(\+|-)?([0-9a-fx]+)(-|\.\.)(\+|-)?([0-9a-fx]+)//) {		#is a range
	$n1= "$1$2";	$n2= "$4$5";
	if($n1=~ s/^(\+|-)?0x//) { $n1= $1 . hex($n1); $has_hex= 1;}
	if($n2=~ s/^(\+|-)?0x//) { $n2= $1 . hex($n2); $has_hex= 1;}
	
	if($n1 > $n2) {
		## &rt_error("from ($n1) is greater than to ($n2)");
		$tmp= $n1;
		$n1= $n2;
		$n2= $tmp;
		}
	$num_items += $n2- $n1+ 1;
	@range= (@range, $n1, $n2);			# $list= 'x-y...'
    }elsif($list =~ s/^(\+|-)?([0-9a-fx]+)//) {
	$n1= "$1$2";
	if($n1=~ s/^(\+|-)?0x//) { $n1= $1 . hex($n1); $has_hex= 1;}
	++ $num_items;
	@value= (@value, $n1);				# $list= 'x.....'
    }else{	& rt_error("illegal number list: [$list_save]"); }

    $list =~ s/^\s*//;
    if($list eq '') {			last;
    }elsif($list !~ s/^,\s*//) {
	$list=~ /^(.)/;
	& rt_error(", expected but got `$1' in number list: [$list_save]");
	}
    } #end of while(1)

########### select from [$list]
my($elm_idx, $result);

#-------------------------------$str_list_${idx} will be a $gloabl variable
my($mark)= ($cmd =~ s/D:?(\w+)//) ? $1 : '';

if(    $cmd eq 'l') {		return($num_items);
}elsif($cmd =~ s/U:?(\w+)//) {	$elm_idx= $DEF_ORDER{$1} % $num_items;
}elsif($cmd =~ /e/) {
	$elm_idx= eval("++ \$str_list_$idx") -1 ;
	if($elm_idx > $num_items-1) { $elm_idx= 0;
				      eval("\$str_list_$idx= 1"); }
# }elsif($cmd =~ /r/) {	$elm_idx= int(rand($num_items));
}else{			$elm_idx= int(rand($num_items));
# }else {	& rt_error("No such number list command: $cmd");
	}
$DEF_ORDER{$mark}= $elm_idx	if($mark);

if($elm_idx <= $#value) {	$result= $value[$elm_idx];
}else{	$lb= $#value;
	for($i= 0; $i <= $#range; $i+=2) {
	   $ub= $lb+ ($range[$i+1] - $range[$i] + 1);
	   if($elm_idx <= $ub) {
		$result= $range[$i]+ $elm_idx- ($lb+ 1);
		last;
		}
	   $lb= $ub;
	   }
	}

$format= ($cmd=~/(\d+)([doxs])/) ? "%$1$2" :		#new
	 ($cmd=~/([doxs])(\d*)/) ? "%$2$1" :
	 $has_hex ?	          "%x"    :
			          "%d"    ;
$result= sprintf($format, $result);

$result;
}

sub   rt_error { print STDERR "\nERR ($LINE_INFO_FOR_ERR): @_\n";     exit(1); }

1;
