OpenCores
URL https://opencores.org/ocsvn/an-fpga-implementation-of-low-latency-noc-based-mpsoc/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk

Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc

Compare Revisions

  • This comparison shows the changes necessary to convert path
    /an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk/mpsoc/Integration_test
    from Rev 55 to Rev 56
    Reverse comparison

Rev 55 → Rev 56

/Altera/report
0,0 → 1,47
extract_results(/home/alireza/work/git/hca_git/mpsoc_work/verify/quartus_pronoc,pronoc);
/home/alireza/work/git/hca_git/mpsoc_work/verify/quartus_pronoc
***************** results *****************
, Fr_max
pronoc_output_files, 125.9 , Fmax = 125.9 Mhz
 
 
 
 
-, Combinational ALUTs
pronoc_output_files, 12032 , 36100 ( 33 % ) ;
 
 
 
 
-, Dedicated logic registers
pronoc_output_files, 9376 , 36100 ( 26 % ) ;
 
 
 
 
-, Memory ALUTs
pronoc_output_files, 0 , 18050 ( 0 % ) ;
 
 
 
 
-, ALMs: partially or completely used
pronoc_output_files, 9309 , 18050 ( 52 % )
 
 
 
 
-, Logic utilization
pronoc_output_files, 14767 , 36100 ( 41 % )
 
 
 
 
-, M9K blocks
pronoc_output_files, 33 , 319 ( 10 % ) ;
 
 
 
 
-, Total block memory bits
pronoc_output_files, 16320 , 2939904 ( < 1 % ) ;
/Altera/report_old
0,0 → 1,46
***************** results *****************
, Fr_max
pronoc_output_files, 125.5 , Fmax = 125.5 Mhz
 
 
 
 
-, Combinational ALUTs
pronoc_output_files, 12019 , 36100 ( 33 % ) ;
 
 
 
 
-, Dedicated logic registers
pronoc_output_files, 9370 , 36100 ( 26 % ) ;
 
 
 
 
-, Memory ALUTs
pronoc_output_files, 0 , 18050 ( 0 % ) ;
 
 
 
 
-, ALMs: partially or completely used
pronoc_output_files, 9253 , 18050 ( 51 % )
 
 
 
 
-, Logic utilization
pronoc_output_files, 15031 , 36100 ( 42 % )
 
 
 
 
-, M9K blocks
pronoc_output_files, 33 , 319 ( 10 % ) ;
 
 
 
 
-, Total block memory bits
pronoc_output_files, 16320 , 2939904 ( < 1 % ) ;
 
/Altera/run.sh
0,0 → 1,129
#!/bin/bash
 
SCRPT_FULL_PATH=$(realpath ${BASH_SOURCE[0]})
SCRPT_DIR_PATH=$(dirname $SCRPT_FULL_PATH)
 
 
 
 
work="${PRONOC_WORK}/verify/quartus_pronoc"
top="quartus_pronoc"
 
 
 
 
 
 
 
 
 
copy_filelist () {
fname=$1
local DIR="$(dirname "${fname}")"
 
 
echo $DIR
pwd
 
while read line; do
# reading each line
#echo $line
cd $DIR
if test -f "$DIR/$line"; then
echo "copy $DIR/$line "
cp "$DIR/$line" $PITON_ROOT/build/src_verilog/
fi
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces
if [[ $line == -F* ]] || [[ $line == -f* ]] ; then
line=${line:2} # Remove the first three chars (leaving 4..end)
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces
echo $line
echo "got another file list $line"
copy_filelist "$DIR/$line"
fi
done < $fname
}
 
 
 
 
 
 
make_qsf () {
fname=$1
oname=$2
local DIR="$(dirname "${fname}")"
 
 
echo $oname
pwd
 
while read line; do
# reading each line
#echo $line
cd $DIR
if test -f "$DIR/$line"; then
echo "set_global_assignment -name SYSTEMVERILOG_FILE $DIR/$line">>"$oname"
# "$DIR/$line" $PITON_ROOT/build/src_verilog/
fi
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces
if [[ $line == -F* ]] || [[ $line == -f* ]] ; then
line=${line:2} # Remove the first three chars (leaving 4..end)
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces
#echo $line
echo "got another file list $line"
make_qsf "$DIR/$line" "$oname"
fi
 
if [[ $line == +incdir+* ]] ; then
line=${line:8} # Remove the first three chars (leaving 4..end)
echo "set_global_assignment -name SEARCH_PATH $DIR/$line">>"$oname"
fi
 
done < $fname
}
 
 
compile () {
 
mkdir -p $work
filename=$SCRPT_DIR_PATH/src/file_list.f
qsf_name="$work/pronoc.qsf"
cp -f $SCRPT_DIR_PATH/src/pronoc.qsf $qsf_name
 
echo "set_global_assignment -name TOP_LEVEL_ENTITY $top">>$qsf_name
make_qsf $filename "$qsf_name"
 
 
 
 
if [[ -z "${Quartus_bin}" ]]; then
#"Some default value because Quartus_bin is undefined"
Quartus_bin="/home/alireza/intelFPGA_lite/18.1/quartus/bin"
else
Quartus_bin="${Quartus_bin}"
fi
 
cd $work
$Quartus_bin/quartus_map --64bit pronoc --read_settings_files=on
$Quartus_bin/quartus_fit --64bit pronoc --read_settings_files=on
$Quartus_bin/quartus_asm --64bit pronoc --read_settings_files=on
$Quartus_bin/quartus_sta --64bit pronoc
 
}
 
 
compile
 
wait;
 
perl ${SCRPT_DIR_PATH}/src/extract.prl "$PRONOC_WORK/verify/quartus_pronoc" "pronoc" > report
 
 
 
Altera/run.sh Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: Altera/src/altera_reset_synchronizer.v =================================================================== --- Altera/src/altera_reset_synchronizer.v (nonexistent) +++ Altera/src/altera_reset_synchronizer.v (revision 56) @@ -0,0 +1,91 @@ +// (C) 2001-2013 Altera Corporation. All rights reserved. +// Your use of Altera Corporation's design tools, logic functions and other +// software and tools, and its AMPP partner logic functions, and any output +// files any of the foregoing (including device programming or simulation +// files), and any associated documentation or information are expressly subject +// to the terms and conditions of the Altera Program License Subscription +// Agreement, Altera MegaCore Function License Agreement, or other applicable +// license agreement, including, without limitation, that your use is for the +// sole purpose of programming logic devices manufactured by Altera and sold by +// Altera or its authorized distributors. Please refer to the applicable +// agreement for further details. + + +// $Id: //acds/rel/13.0/ip/merlin/altera_reset_controller/altera_reset_synchronizer.v#1 $ +// $Revision: #1 $ +// $Date: 2013/02/11 $ +// $Author: swbranch $ + +// ----------------------------------------------- +// Reset Synchronizer +// ----------------------------------------------- + +// synthesis translate_off +`timescale 1ns / 1ps +// synthesis translate_on + + +module altera_reset_synchronizer +#( + parameter ASYNC_RESET = 0, + parameter DEPTH = 2 +) +( + input reset_in /* synthesis ALTERA_ATTRIBUTE = "SUPPRESS_DA_RULE_INTERNAL=R101" */, + + input clk, + output reset_out +); + + // ----------------------------------------------- + // Synchronizer register chain. We cannot reuse the + // standard synchronizer in this implementation + // because our timing constraints are different. + // + // Instead of cutting the timing path to the d-input + // on the first flop we need to cut the aclr input. + // + // We omit the "preserve" attribute on the final + // output register, so that the synthesis tool can + // duplicate it where needed. + // ----------------------------------------------- + (*preserve*) reg [DEPTH-1:0] altera_reset_synchronizer_int_chain; + reg altera_reset_synchronizer_int_chain_out; + + generate if (ASYNC_RESET) begin + + // ----------------------------------------------- + // Assert asynchronously, deassert synchronously. + // ----------------------------------------------- + always @(posedge clk or posedge reset_in) begin + if (reset_in) begin + altera_reset_synchronizer_int_chain <= {DEPTH{1'b1}}; + altera_reset_synchronizer_int_chain_out <= 1'b1; + end + else begin + altera_reset_synchronizer_int_chain[DEPTH-2:0] <= altera_reset_synchronizer_int_chain[DEPTH-1:1]; + altera_reset_synchronizer_int_chain[DEPTH-1] <= 0; + altera_reset_synchronizer_int_chain_out <= altera_reset_synchronizer_int_chain[0]; + end + end + + assign reset_out = altera_reset_synchronizer_int_chain_out; + + end else begin + + // ----------------------------------------------- + // Assert synchronously, deassert synchronously. + // ----------------------------------------------- + always @(posedge clk) begin + altera_reset_synchronizer_int_chain[DEPTH-2:0] <= altera_reset_synchronizer_int_chain[DEPTH-1:1]; + altera_reset_synchronizer_int_chain[DEPTH-1] <= reset_in; + altera_reset_synchronizer_int_chain_out <= altera_reset_synchronizer_int_chain[0]; + end + + assign reset_out = altera_reset_synchronizer_int_chain_out; + + end + endgenerate + +endmodule +
Altera/src/altera_reset_synchronizer.v Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: Altera/src/extract.prl =================================================================== --- Altera/src/extract.prl (nonexistent) +++ Altera/src/extract.prl (revision 56) @@ -0,0 +1,116 @@ +#!/usr/bin/perl -w +use Cwd qw(getcwd); +use IPC::Run qw( run start pump finish timeout ); + + + +my @HWs = ( +"; Logic utilization ;", +"; Combinational ALUTs ;", +"; Memory ALUTs ;", +"; Dedicated logic registers ;", +"; Total block memory bits ;", +"; ALMs: partially or completely used ;", +"; M9K blocks ;" + +); + + + +my $csv=""; +my %freq; +my %results; + +sub extract_results { + my ($dir,$parent) =@_; + my @cat = qw( bash ); + chdir "$dir"; + print getcwd()."\n"; + + my ($in, $out, $err); + #Fmax + $in ='grep -R "; clk ; ;$" | sort'; + run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "grep: $?"; + + + my @lines = split("\n",$out); + foreach my $l (@lines) { + + my @f=split ('/',$l); + my $name= "${parent}_$f[0]"; + + @f=split (':',$l); + @f=split (';',$f[1]); + $f[1] =~ s/MHz//; + + if(!defined $freq{$name}){ + $freq{$name}=$f[1]; + }else{#get the minum reported max frequency + $freq{$name}=$f[1] if($f[1]< $freq{$name}); + } + + } + + + + + foreach my $hw (@HWs){ + + + + my @cat = qw( bash ); + my $in ="grep -R \"$hw\" | sort"; + $hw =~ s/[\;]//g; + + #$csv.="-,$hw\n"; + $out=undef; + run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "grep: $?"; + @lines = split("\n",$out); + + foreach my $l (@lines) { + unless ( index($l,".fit.rpt") >= 0){ next;} + + my @f=split ('/',$l); + + my $name= "${parent}_$f[0]"; + my @ff = split (/\; /,$l); + my $val=$ff[2]; + $val =~ s/,//g; + my @vv = split ("/",$val); + my $t =join(',',@vv); + #$csv.= "$name, $t \n" if (defined $val) ; + $results{$hw}{$name}=$t if (defined $val) ; + } + } + +} + + + +print "extract_results($ARGV[0],$ARGV[1]);\n"; + +extract_results($ARGV[0],$ARGV[1]); + + + + +$csv.=" , Fr_max\n"; +foreach my $p (sort keys %freq){ + $csv.= "$p, $freq{$p}, Fmax = $freq{$p} Mhz\n"; +} + + +foreach my $p (sort keys %results){ + my $ref = $results{$p}; + my %r = %{$results{$p}} if (defined $ref) ; + $csv.= "\n\n\n\n" ; + $csv.="-,$p\n"; + foreach my $p (sort keys %r){ + $csv.= "$p, $r{$p} \n"; + } + +} + +print "***************** results *****************\n"; + print $csv; +
Altera/src/extract.prl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: Altera/src/file_list.f =================================================================== --- Altera/src/file_list.f (nonexistent) +++ Altera/src/file_list.f (revision 56) @@ -0,0 +1,9 @@ ++incdir+./ ++incdir+./../../../rtl/src_noc + +-F ../../../rtl/src_noc/noc_filelist.f +-F ../../../rtl/src_topolgy/custom_flist.f + +./quartus_piton_mesh.sv +./quartus_pronoc.sv +./altera_reset_synchronizer.v Index: Altera/src/noc_localparam.v =================================================================== --- Altera/src/noc_localparam.v (nonexistent) +++ Altera/src/noc_localparam.v (revision 56) @@ -0,0 +1,50 @@ + +`ifdef NOC_LOCAL_PARAM + + + + +//NoC parameters + localparam TOPOLOGY="MESH"; + localparam T1=3; + localparam T2=3; + localparam T3=1; + localparam V=2; + localparam B=4; + localparam LB=16; + localparam Fpay=32; + localparam ROUTE_NAME="XY"; + localparam PCK_TYPE = "MULTI_FLIT"; //"SINGLE_FLIT"; + localparam MIN_PCK_SIZE=1; + localparam BYTE_EN=0; + localparam SSA_EN="YES"; + localparam CONGESTION_INDEX=3; + localparam ESCAP_VC_MASK=2'b01; + localparam VC_REALLOCATION_TYPE="NONATOMIC"; + localparam COMBINATION_TYPE="COMB_NONSPEC"; + localparam MUX_TYPE="BINARY"; + localparam C=0; + localparam DEBUG_EN=1; + localparam ADD_PIPREG_AFTER_CROSSBAR=1'b0; + localparam FIRST_ARBITER_EXT_P_EN=1; + localparam SWA_ARBITER_TYPE="RRA"; + localparam WEIGHTw=4; + localparam AVC_ATOMIC_EN=0; + localparam CVw=(C==0)? V : C * V; + localparam CLASS_SETTING={CVw{1'b1}}; + localparam SMART_MAX=0; + localparam SELF_LOOP_EN="YES"; + localparam CAST_TYPE = "UNICAST"; + localparam MCAST_ENDP_LIST = 'b11110011; + //localparam MCAST_PRTLw=6; + + + + //simulation parameter + //localparam MAX_RATIO = 1000; + localparam MAX_PCK_NUM = 1000000000; + localparam MAX_PCK_SIZ = 16383; + localparam MAX_SIM_CLKs= 1000000000; + localparam TIMSTMP_FIFO_NUM = 16; + +`endif Index: Altera/src/pronoc.qsf =================================================================== --- Altera/src/pronoc.qsf (nonexistent) +++ Altera/src/pronoc.qsf (revision 56) @@ -0,0 +1,75 @@ +# Generated using ProNoC +#============================================================ +# Build by Terasic System Builder +#============================================================ + +set_global_assignment -name FAMILY "Arria II GX" +set_global_assignment -name DEVICE EP2AGX45DF29I5 +set_global_assignment -name ORIGINAL_QUARTUS_VERSION 12.0 +set_global_assignment -name LAST_QUARTUS_VERSION "18.1.0 Lite Edition" +set_global_assignment -name PROJECT_CREATION_TIME_DATE "16:38:23 JULY 08,2019" + +#============================================================ +# CLOCK +#============================================================ + +#============================================================ +# LED x 10 +#============================================================ + +#============================================================ +# BUTTON x 4 and CPU_RESET_n +#============================================================ + +#============================================================ +# SWITCH x 4 +#============================================================ + +#============================================================ +# 7-Segement +#============================================================ + +#============================================================ +# Temperature +#============================================================ + +#============================================================ +# Fan +#============================================================ + +#============================================================ +# RS232 +#============================================================ + +#============================================================ +# Flash/MAX Address/Data Share Bus +#============================================================ + +#============================================================ +# Flash Control +#============================================================ + +#============================================================ +# End of pin assignments by Terasic System Builder +#============================================================ + + +set_global_assignment -name PROJECT_OUTPUT_DIRECTORY output_files + + + +set_global_assignment -name MIN_CORE_JUNCTION_TEMP "-40" +set_global_assignment -name MAX_CORE_JUNCTION_TEMP 100 +set_global_assignment -name POWER_PRESET_COOLING_SOLUTION "23 MM HEAT SINK WITH 200 LFPM AIRFLOW" +set_global_assignment -name POWER_BOARD_THERMAL_MODEL "NONE (CONSERVATIVE)" + + +set_global_assignment -name PARTITION_NETLIST_TYPE SOURCE -section_id Top +set_global_assignment -name PARTITION_FITTER_PRESERVATION_LEVEL PLACEMENT_AND_ROUTING -section_id Top +set_global_assignment -name PARTITION_COLOR 16764057 -section_id Top +set_instance_assignment -name PARTITION_HIERARCHY root_partition -to | -section_id Top + + + + + Index: Altera/src/quartus_pronoc.sv =================================================================== --- Altera/src/quartus_pronoc.sv (nonexistent) +++ Altera/src/quartus_pronoc.sv (revision 56) @@ -0,0 +1,67 @@ +`include "pronoc_def.v" + +module quartus_pronoc +#( + parameter NOC_ID = 0 +)( + clk, + reset, + chan_in, + chan_out, + sel_in, + sel_out +); + + `NOC_CONF + + input [NE-1 : 0] sel_in; + input [NEw-1 : 0] sel_out; + input smartflit_chanel_t chan_in; + output smartflit_chanel_t chan_out; + input reset,clk; + + + smartflit_chanel_t chan_in_all [NE-1 : 0]; + smartflit_chanel_t chan_out_all [NE-1 : 0]; + smartflit_chanel_t chan_out_all_reg [NE-1 : 0]; + + wire noc_reset; + + noc_top #( + .NOC_ID(NOC_ID) + ) top ( + .reset(noc_reset), + .clk(clk), + .chan_in_all(chan_in_all), + .chan_out_all(chan_out_all), + .router_event( ) + ); + + + altera_reset_synchronizer sync( + .reset_in (reset), + .clk (clk), + .reset_out (noc_reset) + ); + + //NoC port assignment + + assign chan_out = chan_out_all_reg[sel_out]; + + always @(posedge clk) begin + chan_out_all_reg <= chan_out_all; + end + + genvar IP_NUM; + generate + for (IP_NUM=0; IP_NUM "verilate_mesh.sh", + 'noc_param'=> { + "ROUTE_NAME" => "\"XY\"", + } +}, 'ProNOC' ); Index: FPGA-kc07/src/deafult_noc_param =================================================================== --- FPGA-kc07/src/deafult_noc_param (nonexistent) +++ FPGA-kc07/src/deafult_noc_param (revision 56) @@ -0,0 +1,82 @@ +$model = bless( { + 'noc_param' => { +"TOPOLOGY" => "\"MESH\"", +"T1" => "4", +"T2" => "4", +"T3" => "1", +"V" => "1", +"B" => "4", +"LB" => "B", +"Fpay" => "32", +"ROUTE_NAME" => "\"XY\"", +"PCK_TYPE" => " \"MULTI_FLIT\"", +"MIN_PCK_SIZE" => "2", +"BYTE_EN" => "0", +"SSA_EN" => "\"NO\"", +"CONGESTION_INDEX" => "3", +"ESCAP_VC_MASK" => "2'b01", +"VC_REALLOCATION_TYPE" => "\"NONATOMIC\"", +"COMBINATION_TYPE" => "\"COMB_NONSPEC\"", +"MUX_TYPE" => "\"BINARY\"", +"C" => "0", +"CLASS_SETTING"=> "{V{1'b1}}", +"DEBUG_EN" => "1", +"ADD_PIPREG_AFTER_CROSSBAR" => "1'b0", +"FIRST_ARBITER_EXT_P_EN" => "1", +"SWA_ARBITER_TYPE" => "\"RRA\"", +"WEIGHTw" => "4", +"AVC_ATOMIC_EN" => "0", +"SMART_MAX" => "0", +"SELF_LOOP_EN" => "\"NO\"", +"MAX_PCK_NUM " => " 1000000000", +"MAX_PCK_SIZ " => " 16383" , +"MAX_SIM_CLKs" => " 1000000000", +"TIMSTMP_FIFO_NUM " => " 16", +"CVw"=> "(C==0)? V : C * V", +"CLASS_SETTING" => "{CVw{1'b1}}", +"CAST_TYPE" => "\"UNICAST\"", + }, + + + 'parameters_order' => { +'noc_param' => +[ + 'TOPOLOGY', + 'T1', + 'T2', + 'T3', + 'V', + 'B', + 'LB', + 'Fpay', + 'ROUTE_NAME', + 'PCK_TYPE', + 'MIN_PCK_SIZE', + 'BYTE_EN', + 'SSA_EN', + 'SMART_MAX', + 'CONGESTION_INDEX', + 'ESCAP_VC_MASK', + 'VC_REALLOCATION_TYPE', + 'COMBINATION_TYPE', + 'MUX_TYPE', + 'C', +'CLASS_SETTING', + 'DEBUG_EN', + 'ADD_PIPREG_AFTER_CROSSBAR', + 'FIRST_ARBITER_EXT_P_EN', + 'SWA_ARBITER_TYPE', + 'WEIGHTw', + 'SELF_LOOP_EN', + 'AVC_ATOMIC_EN', +"MAX_PCK_NUM " , +"MAX_PCK_SIZ ", +"MAX_SIM_CLKs", +"TIMSTMP_FIFO_NUM ", +"CVw", +"CAST_TYPE" ], + +} + + }, +); Index: FPGA-kc07/src/src.pl =================================================================== --- FPGA-kc07/src/src.pl (nonexistent) +++ FPGA-kc07/src/src.pl (revision 56) @@ -0,0 +1,470 @@ +#!/usr/bin/perl -w + +use Proc::Background; +use File::Path qw( rmtree ); + +my $script_path = dirname(__FILE__); +my $dirname = "$script_path/.."; +my $root = "$dirname/../.."; +my $rtl_dir = "$ENV{PRONOC_WORK}/verify/rtl"; +my $work = "$ENV{PRONOC_WORK}/verify/work"; +my $src = "$script_path"; +my $report = "$dirname/report"; + +require "$root/perl_gui/lib/perl/common.pl"; +require "$root/perl_gui/lib/perl/topology.pl"; + +use strict; +use warnings; + +my $pp; +$pp= do "$src/deafult_noc_param"; +die "Error reading: $@" if $@; + +my $param = $pp->{'noc_param'}; +my %default_noc_param=%{$param}; +my @params=object_get_attribute_order($pp,'noc_param'); + + + +#read default param + + +sub gen_noc_param_h{ + my $mpsoc=shift; + my $param_h="\n\n//NoC parameters\n"; + + my $topology = $mpsoc->object_get_attribute('noc_param','TOPOLOGY'); + $topology =~ s/"//g; + $param_h.="\t#define IS_${topology}\n"; + + my ($NE, $NR, $RAw, $EAw, $Fw) = get_topology_info($mpsoc); + + my @params=$mpsoc->object_get_attribute_order('noc_param'); + my $custom_topology = $mpsoc->object_get_attribute('noc_param','CUSTOM_TOPOLOGY_NAME'); + foreach my $p (@params){ + my $val=$mpsoc->object_get_attribute('noc_param',$p); + next if($p eq "CUSTOM_TOPOLOGY_NAME"); + $val=$custom_topology if($p eq "TOPOLOGY" && $val eq "\"CUSTOM\""); + if($p eq "MCAST_ENDP_LIST" || $p eq "ESCAP_VC_MASK"){ + $val="$NE".$val if($p eq 'MCAST_ENDP_LIST'); + $val =~ s/\'/\\\'/g; + $val="\"$val\""; + } + + + $param_h=$param_h."\t#define $p\t$val\n"; + + + + } + my $class=$mpsoc->object_get_attribute('noc_param',"C"); + my $str; + if( $class > 1){ + for (my $i=0; $i<=$class-1; $i++){ + my $n="Cn_$i"; + my $val=$mpsoc->object_get_attribute('class_param',$n); + $param_h=$param_h."\t#define $n\t$val\n"; + } + $str="CLASS_SETTING {"; + for (my $i=$class-1; $i>=0;$i--){ + $str=($i==0)? "${str}Cn_0};\n " : "${str}Cn_$i,"; + } + }else { + $str="CLASS_SETTING={V{1\'b1}}\n"; + } + #add_text_to_string (\$param_h,"\t#define $str"); + + my $v=$mpsoc->object_get_attribute('noc_param',"V")-1; + my $escape=$mpsoc->object_get_attribute('noc_param',"ESCAP_VC_MASK"); + if (! defined $escape){ + #add_text_to_string (\$param_h,"\tlocalparam [$v :0] ESCAP_VC_MASK=1;\n"); + #add_text_to_string (\$pass_param,".ESCAP_VC_MASK(ESCAP_VC_MASK),\n"); + } + #add_text_to_string (\$param_h," \tlocalparam CVw=(C==0)? V : C * V;\n"); + #add_text_to_string (\$pass_param,".CVw(CVw)\n"); + + #remove 'b and 'h + #$param_h =~ s/\d\'b/ /g; + #$param_h =~ s/\'h/ /g; + + + return $param_h; +} + + + + +sub get_model_parameter { + my $model =shift; + my $o; + $o= do $model; + my %new_param=%{$o}; + die "Error reading: $@" if $@; + my %temp; + foreach my $p (@params){ + $temp{$p} = $default_noc_param{$p}; + } + foreach my $p (sort keys %new_param){ + $temp{$p} = $new_param{$p}; + } + return %temp; +} + +sub gen_noc_localparam_v { + my ($m,$ref) = @_; + my %model = %{$ref}; + my %temp; + + + foreach my $p (@params){ + $temp{$p} = $default_noc_param{$p}; + $m->{noc_param}{$p}=$default_noc_param{$p}; + } + foreach my $p (sort keys %model){ + $temp{$p} = $model{$p}; + $m->{noc_param}{$p}=$model{$p}; + } + + object_add_attribute_order($m,'noc_param',@params); + + my $param_v="`ifdef NOC_LOCAL_PARAM \n"; + foreach my $p (@params){ + $param_v.="localparam $p = $temp{$p};\n"; + } + $param_v.="`endif\n"; + + my ($nr,$ne,$router_p,$ref_tops,$includ_h) = get_noc_verilator_top_modules_info($m); + my %tops = %{$ref_tops}; + $tops{Vtraffic} = "--top-module traffic_gen_top"; + $tops{Vpck_inj} = "--top-module packet_injector_verilator"; + + + + + my $param_h=gen_noc_param_h($m); + $includ_h = gen_sim_parameter_h($param_h,$includ_h,$ne,$nr,$router_p,'16'); + + return ($param_v,$includ_h,\%tops); + +} + + +sub copy_src_files{ + + if(defined $ENV{PRONOC_WORK}){ + rmtree("$rtl_dir"); + unless (-d "$rtl_dir"){ + print "make a working directory inside $rtl_dir\n"; + mkdir("$rtl_dir", 0700); + + } + }else{ + print "Please set PRONOC_WORK variable first!"; + exit; + } + + dircopy("$root/rtl/src_noc" , "$rtl_dir/src_noc" ) or die("$!\n") unless (-d "$rtl_dir/src_noc" ); + dircopy("$root/rtl/src_topolgy", "$rtl_dir/src_topolgy") or die("$!\n") unless (-d "$rtl_dir/src_topolgy"); + + unlink "$rtl_dir/src_noc/noc_localparam.v"; + for my $file (glob "$root/rtl/*.v") { + copy $file, "$rtl_dir" or die $! ; + } + + + +} + + + + +sub gen_file_list{ + my $path=shift; + my $f="+incdir+$rtl_dir/ ++incdir+$rtl_dir/src_noc/ ++incdir+$path +"; + + my @files = File::Find::Rule->file() + ->name( '*.v','*.V','*.sv' ) + ->in( "$rtl_dir" ); + + #make sure source files have key word 'module' + my @sources; + foreach my $p (@files){ + push (@sources,$p) if(check_file_has_string($p,'endpackage')); + } + foreach my $p (@files){ + push (@sources,$p) if(check_file_has_string($p,'module')); + } + my $files = join ("\n",@sources); + $f.=$files; + + + open(FILE, ">$path/file_list.f") || die "Can not open: $!"; + print FILE $f; + close FILE; +} + + + +sub gen_models { + my @models = glob("$dirname/models/*"); + mkdir("$work", 0700); + foreach my $m (@models){ + print "$m\n"; + #make noc localparam + my $o; + $o= do $m; + die "Error reading: $@" if $@; + my $param = $o->{'noc_param'}; + my ($fname,$fpath,$fsuffix) = fileparse("$m",qr"\..[^.]*$"); + + + my $name = $fname; + my $make =$o->{'makefile'}; + + + my ($param_v,$include_h,$tops)= gen_noc_localparam_v( $o,$param); + + mkdir("$work/$name", 0700); + save_file("$work/$name/noc_localparam.v",$param_v); + + #generate file list + gen_file_list("$work/$name"); + + + + + } + +} + + + + + + +sub compile_models{ + my($self,$inref)=@_; + my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref}; + my @models = glob("$dirname/models/*"); + #generate compile command + my $i=0; + my $cmd; + foreach my $m (@models){ + my ($fname,$fpath,$fsuffix) = fileparse("$m",qr"\..[^.]*$"); + $cmd.=" cd $work/$fname; bash verilator.sh > $work/$fname/out.log 2>&1 &\n"; + $i++; + $cmd.="wait\n" if(($i % $paralel_run)==0) ; + } + $cmd.="wait\n" if(($i % $paralel_run)!=0) ; + #run command in terminal + print "*******************compile models******************\n$cmd\n"; + my $proc1 = Proc::Background->new($cmd); + $proc1->alive; + $proc1->wait; + $proc1->die; + +} + + + + + + +sub check_compilation_log { + my ($name,$ref,$inref) = @_; + my @log_report_match =@{$ref}; + my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref}; + my $logfile = "$work/$name/out.log"; + + my @found; + foreach my $m (@log_report_match){ + open my $INPUT, '<', $logfile; + push(@found , grep ( /$m/, <$INPUT>)) ; + close($INPUT); + } + + foreach my $line (@found) { + append_text_to_file($report,"\t $line\n"); + } +} + + + + + +sub check_compilation { + my ($self,$ref1,$ref2)=@_; + my @models = glob("$dirname/models/*"); + foreach my $m (@models){ + my ($name,$fpath,$fsuffix) = fileparse("$m",qr"\..[^.]*$"); + append_text_to_file($report,"****************************$name : Compile *******************************:\n"); + #check if testbench is generated successfully + if(-f "$work/$name/obj_dir/testbench"){ + append_text_to_file($report,"\t model is generated successfully.\n"); + check_compilation_log($name,$ref1,$ref2); + + }else{ + append_text_to_file($report,"\t model generation is FAILED.\n"); + check_compilation_log($name,$ref1,$ref2); + } + + } +} + + +sub run_all_models { + my ($self,$inref) =@_; + my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref}; + my @models = glob("$dirname/models/*"); + foreach my $m (@models){ + run_traffic ($self,$m,'random',$inref); + } + foreach my $m (@models){ + run_traffic ($self,$m,'transposed 1',$inref); + } +} + + + +sub run_traffic { + my ($self,$model,$traffic,$inref)=@_; + my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref}; + my ($name,$fpath,$fsuffix) = fileparse("$model",qr"\..[^.]*$"); + + my %param = get_model_parameter($model); + my $min_pck = $param{'MIN_PCK_SIZE'}; + + append_text_to_file($report,"****************************$name : $traffic traffic *******************************:\n"); + unless (-f "$work/$name/obj_dir/testbench"){ + append_text_to_file($report,"\t failed. Simulation model is not avaialable\n"); + return; + } + + + + my $file_name="${traffic}_results"; + $file_name =~ s/\s+//g; + + mkdir("$work/$name/$file_name/", 0700); + + my $i=0; + my $cmd; + + + for (my $inject=$MIN; $inject<=$MAX; $inject+=$STEP){ + $cmd.="$work/$name/obj_dir/testbench -t \"$traffic\" -m \"R,$min_pck,10\" -n 20000 -c 10000 -i $inject -p \"100,0,0,0,0\" > $work/$name/$file_name/sim$inject 2>&1 &\n"; + $i++; + $cmd.="wait\n" if(($i % $paralel_run)==0) ; + } + $cmd.="wait\n" if(($i % $paralel_run)!=0) ; + #run command in terminal + print "*******************run models******************\n$cmd\n"; + my $proc1 = Proc::Background->new($cmd); + $proc1->alive; + $proc1->wait; + $proc1->die; + + check_sim_results($self,$name,$traffic,$inref); + +} + + +sub extract_result { + my ($self,$file,$filed)=@_; + + my @r = unix_grep($file,$filed); + my $string = $r[0]; + $string =~ s/[^0-9.]+//g; + return $string; + +} + +sub get_zero_load_and_saturation{ + my ($self,$name,$traffic,$path)=@_; + my %results; + my $ref = $self->{'name'}{"$name"}{'traffic'}{$traffic}{"packet_latency"}; + return if !defined $ref; + %results = %{$ref}; + + my $zero_latency=9999999; + my $saturat_inject=100; + my $zero_inject; + my $saturat_latency='-'; + + my $txt = "#name:$name\n"; + + foreach my $inj (sort {$a <=> $b} keys %results){ + $txt.="$inj $results{$inj}\n"; + if ($zero_latency > $results{$inj}) { + $zero_latency = $results{$inj}; + $zero_inject = $inj; + } + } + # assum saturation happens when the latency is 5 times of zero load + foreach my $inj (sort {$a <=> $b} keys %results){ + if($results{$inj} >= 5 * $zero_latency ) { + if($saturat_inject > $inj){ + $saturat_inject =$inj; + $saturat_latency=$results{$inj}; + } + } + } + $txt.="\n"; + save_file("$path/packet_latency.sv",$txt); + + + return ($zero_inject,$zero_latency, $saturat_inject,$saturat_latency); +} + + + + +sub check_sim_results{ + my ($self,$name,$traffic,$inref)=@_; + my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref}; + my $file_name="${traffic}_results"; + $file_name =~ s/\s+//g; + my $results_path = "$work/$name/$file_name"; + + #my @results = glob("$results_path/*"); + #check for error + + for (my $inject=$MIN; $inject<=$MAX; $inject+=$STEP){ + my $file = "$results_path/sim$inject"; + + my @errors = unix_grep("$file","ERROR:"); + if (scalar @errors ){ + append_text_to_file($report,"\t Error in running simulation: @errors \n"); + $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="Failed"; + $self->{'name'}{"$name"}{'traffic'}{$traffic}{'message'}="@errors"; + return; + } + my @r = unix_grep($file,"total,"); + my $string = $r[0]; + my @fileds=split(',',$string); + my $val=$fileds[11]; + $val =~ s/[^0-9.]+//g; + # my $val = extract_result($self,$file,"average packet latency"); + if(length $val ==0){ + $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="Failed"; + $self->{'name'}{"$name"}{'traffic'}{$traffic}{'message'}="The average packet latency is undefined for $inject"; + return; + } + $self->{'name'}{"$name"}{'traffic'}{$traffic}{"packet_latency"}{$inject}="$val"; + + } + my ($z,$zl, $s,$sl) = get_zero_load_and_saturation ($self,$name,$traffic,$results_path); + print "($z,$zl, $s,$sl)\n"; + + #save results in a text file + + + + append_text_to_file($report,"\t Passed: zero load ($z,$zl) saturation ($s,$sl)\n"); + $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="passed"; +} +
FPGA-kc07/src/src.pl Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: synthetic_sim/failed-model/line2_2cycle_mcast_f =================================================================== --- synthetic_sim/failed-model/line2_2cycle_mcast_f (nonexistent) +++ synthetic_sim/failed-model/line2_2cycle_mcast_f (revision 56) @@ -0,0 +1,12 @@ +$model = bless( { + + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "T1" => "4", + "T2" => "4", + "CAST_TYPE" => "\"MULTICAST_FULL\"", + "Fpay" => "64", + "MCAST_ENDP_LIST" => "'b11", + + } +}, 'ProNOC' ); Index: synthetic_sim/line/Line_3x2_v2 =================================================================== --- synthetic_sim/line/Line_3x2_v2 (nonexistent) +++ synthetic_sim/line/Line_3x2_v2 (revision 56) @@ -0,0 +1,18 @@ +$model = bless( { + + 'noc_param'=> { + "TOPOLOGY" => "\"LINE\"", + "T1" => "3", + "T2" => "1", + "T3" => "4", + "V" => "2", + "B" => "4", + "LB" => "4", + "Fpay" => "32", + "ROUTE_NAME"=>"\"XY\"" + + } +}, 'ProNOC' ); + + + Index: synthetic_sim/line/line2_openpiton =================================================================== --- synthetic_sim/line/line2_openpiton (nonexistent) +++ synthetic_sim/line/line2_openpiton (revision 56) @@ -0,0 +1,14 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "T1" => "2", + "V" => "1", + "ESCAP_VC_MASK" => "1'b1", + "B" => "4", + "LB" => "16", + "Fpay" => "64", + "SSA_EN" => "\"YES\"", + "SELF_LOOP_EN" => "\"YES\"", + "MCAST_ENDP_LIST" => "'b11", + } +}, 'ProNOC' ); Index: synthetic_sim/line/line4_smart3 =================================================================== --- synthetic_sim/line/line4_smart3 (nonexistent) +++ synthetic_sim/line/line4_smart3 (revision 56) @@ -0,0 +1,16 @@ +$model = bless( { + 'noc_param'=> { + "SMART_MAX" => "3", + TOPOLOGY=>"\"LINE\"", + "T1" => "4", + "T2" => "4", + "V" => "1", + "ESCAP_VC_MASK" => "1'b1", + "B" => "4", + "LB" => "16", + "Fpay" => "64", + "SSA_EN" => "\"NO\"", + "SELF_LOOP_EN" => "\"YES\"", + "MCAST_ENDP_LIST" => "'b11", + } +}, 'ProNOC' ); Index: synthetic_sim/line/line_4_v1_B15 =================================================================== --- synthetic_sim/line/line_4_v1_B15 (nonexistent) +++ synthetic_sim/line/line_4_v1_B15 (revision 56) @@ -0,0 +1,21 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "T1" => "4", + "T2" => "4", + "V" => "1", + "ESCAP_VC_MASK" => "1'b1", + "B" => "15", + "LB" => "15", + "Fpay" => "64", + "SSA_EN" => "\"NO\"", + "SELF_LOOP_EN" => "\"NO\"", + } +}, 'ProNOC' ); + + + + + + + Index: synthetic_sim/line/line_4x3_2cycle_xy =================================================================== --- synthetic_sim/line/line_4x3_2cycle_xy (nonexistent) +++ synthetic_sim/line/line_4x3_2cycle_xy (revision 56) @@ -0,0 +1,10 @@ +$model = bless( { + 'compile' => "verilate_mesh.sh", + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "T1" => "4", + "T2" => "4", + "T3" => "3", + "ROUTE_NAME" => "\"XY\"", + } +}, 'ProNOC' ); Index: synthetic_sim/line/line_8_2cycle_xy =================================================================== --- synthetic_sim/line/line_8_2cycle_xy (nonexistent) +++ synthetic_sim/line/line_8_2cycle_xy (revision 56) @@ -0,0 +1,6 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "ROUTE_NAME" => "\"XY\"", + } +}, 'ProNOC' ); Index: synthetic_sim/line/line_8_b2 =================================================================== --- synthetic_sim/line/line_8_b2 (nonexistent) +++ synthetic_sim/line/line_8_b2 (revision 56) @@ -0,0 +1,8 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "ROUTE_NAME" => "\"XY\"", + "B"=> "2", + "LB"=> 2 + } +}, 'ProNOC' ); Index: synthetic_sim/line/line_8_sbp6_xy =================================================================== --- synthetic_sim/line/line_8_sbp6_xy (nonexistent) +++ synthetic_sim/line/line_8_sbp6_xy (revision 56) @@ -0,0 +1,6 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "SMART_MAX" => "6", + } +}, 'ProNOC' ); Index: synthetic_sim/line/line_8_single_flit =================================================================== --- synthetic_sim/line/line_8_single_flit (nonexistent) +++ synthetic_sim/line/line_8_single_flit (revision 56) @@ -0,0 +1,10 @@ +$model = bless( { + + 'noc_param'=> { +TOPOLOGY=>"\"LINE\"", + "B" => "5", + "LB" => "5", + "MIN_PCK_SIZE" => "1", + "PCK_TYPE" => " \"SINGLE_FLIT\"", + } +}, 'ProNOC' ); Index: synthetic_sim/line/line_8x8_ssa_xy =================================================================== --- synthetic_sim/line/line_8x8_ssa_xy (nonexistent) +++ synthetic_sim/line/line_8x8_ssa_xy (revision 56) @@ -0,0 +1,6 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "SSA_EN" => "\"YES\"", + } +}, 'ProNOC' ); Index: synthetic_sim/line/linex8_4vc_4c =================================================================== --- synthetic_sim/line/linex8_4vc_4c (nonexistent) +++ synthetic_sim/line/linex8_4vc_4c (revision 56) @@ -0,0 +1,10 @@ +$model = bless( { + 'noc_param'=> { + TOPOLOGY=>"\"LINE\"", + "ROUTE_NAME" => "\"XY\"", + "V" => 4, + "C" => 4, + "CLASS_SETTING" => "16'b1000010000100001", + "ESCAP_VC_MASK" => "4'b1000" + } +}, 'ProNOC' ); Index: synthetic_sim/line/ring_8x8_2cycle_xy =================================================================== --- synthetic_sim/line/ring_8x8_2cycle_xy (nonexistent) +++ synthetic_sim/line/ring_8x8_2cycle_xy (revision 56) @@ -0,0 +1,8 @@ +$model = bless( { + 'compile' => "verilate_mesh.sh", + 'noc_param'=> { + TOPOLOGY=>"\"RING\"", + "TOPOLOGY" => "\"TORUS\"", + "ROUTE_NAME" => "\"TRANC_XY\"", + } +}, 'ProNOC' ); Index: synthetic_sim/models/mesh_4x4_smart3 =================================================================== --- synthetic_sim/models/mesh_4x4_smart3 (nonexistent) +++ synthetic_sim/models/mesh_4x4_smart3 (revision 56) @@ -0,0 +1,15 @@ +$model = bless( { + 'noc_param'=> { + "SMART_MAX" => "3", + "TOPOLOGY"=> "\"FMESH\"", + "T1" => "4", + "T2" => "4", + "V" => "1", + "ESCAP_VC_MASK" => "1'b1", + "B" => "4", + "LB" => "16", + "Fpay" => "64", + "SSA_EN" => "\"NO\"", + "SELF_LOOP_EN" => "\"YES\"", + } +}, 'ProNOC' ); Index: synthetic_sim/perl_lib/Class/Accessor/Fast.pm =================================================================== --- synthetic_sim/perl_lib/Class/Accessor/Fast.pm (nonexistent) +++ synthetic_sim/perl_lib/Class/Accessor/Fast.pm (revision 56) @@ -0,0 +1,97 @@ +package Class::Accessor::Fast; +use base 'Class::Accessor'; +use strict; +use B 'perlstring'; +$Class::Accessor::Fast::VERSION = '0.51'; + +sub make_accessor { + my ($class, $field) = @_; + + eval sprintf q{ + sub { + return $_[0]{%s} if scalar(@_) == 1; + return $_[0]{%s} = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]]; + } + }, map { perlstring($_) } $field, $field; +} + +sub make_ro_accessor { + my($class, $field) = @_; + + eval sprintf q{ + sub { + return $_[0]{%s} if @_ == 1; + my $caller = caller; + $_[0]->_croak(sprintf "'$caller' cannot alter the value of '%%s' on objects of class '%%s'", %s, %s); + } + }, map { perlstring($_) } $field, $field, $class; +} + +sub make_wo_accessor { + my($class, $field) = @_; + + eval sprintf q{ + sub { + if (@_ == 1) { + my $caller = caller; + $_[0]->_croak(sprintf "'$caller' cannot access the value of '%%s' on objects of class '%%s'", %s, %s); + } + else { + return $_[0]{%s} = $_[1] if @_ == 2; + return (shift)->{%s} = \@_; + } + } + }, map { perlstring($_) } $field, $class, $field, $field; +} + +1; + +__END__ + +=head1 NAME + +Class::Accessor::Fast - Faster, but less expandable, accessors + +=head1 SYNOPSIS + + package Foo; + use base qw(Class::Accessor::Fast); + + # The rest is the same as Class::Accessor but without set() and get(). + +=head1 DESCRIPTION + +This is a faster but less expandable version of Class::Accessor. +Class::Accessor's generated accessors require two method calls to accomplish +their task (one for the accessor, another for get() or set()). +Class::Accessor::Fast eliminates calling set()/get() and does the access itself, +resulting in a somewhat faster accessor. + +The downside is that you can't easily alter the behavior of your +accessors, nor can your subclasses. Of course, should you need this +later, you can always swap out Class::Accessor::Fast for +Class::Accessor. + +Read the documentation for Class::Accessor for more info. + +=head1 EFFICIENCY + +L for an efficiency comparison. + +=head1 AUTHORS + +Copyright 2017 Marty Pauley + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. That means either (a) the GNU General Public +License or (b) the Artistic License. + +=head2 ORIGINAL AUTHOR + +Michael G Schwern + +=head1 SEE ALSO + +L + +=cut Index: synthetic_sim/perl_lib/Class/Accessor/Faster.pm =================================================================== --- synthetic_sim/perl_lib/Class/Accessor/Faster.pm (nonexistent) +++ synthetic_sim/perl_lib/Class/Accessor/Faster.pm (revision 56) @@ -0,0 +1,109 @@ +package Class::Accessor::Faster; +use base 'Class::Accessor'; +use strict; +use B 'perlstring'; +$Class::Accessor::Faster::VERSION = '0.51'; + +my %slot; +sub _slot { + my($class, $field) = @_; + my $n = $slot{$class}->{$field}; + return $n if defined $n; + $n = keys %{$slot{$class}}; + $slot{$class}->{$field} = $n; + return $n; +} + +sub new { + my($proto, $fields) = @_; + my($class) = ref $proto || $proto; + my $self = bless [], $class; + + $fields = {} unless defined $fields; + for my $k (keys %$fields) { + my $n = $class->_slot($k); + $self->[$n] = $fields->{$k}; + } + return $self; +} + +sub make_accessor { + my($class, $field) = @_; + my $n = $class->_slot($field); + eval sprintf q{ + sub { + return $_[0][%d] if scalar(@_) == 1; + return $_[0][%d] = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]]; + } + }, $n, $n; +} + +sub make_ro_accessor { + my($class, $field) = @_; + my $n = $class->_slot($field); + eval sprintf q{ + sub { + return $_[0][%d] if @_ == 1; + my $caller = caller; + $_[0]->_croak(sprintf "'$caller' cannot alter the value of '%%s' on objects of class '%%s'", %s, %s); + } + }, $n, map(perlstring($_), $field, $class); +} + +sub make_wo_accessor { + my($class, $field) = @_; + my $n = $class->_slot($field); + eval sprintf q{ + sub { + if (@_ == 1) { + my $caller = caller; + $_[0]->_croak(sprintf "'$caller' cannot access the value of '%%s' on objects of class '%%s'", %s, %s); + } + else { + return $_[0][%d] = $_[1] if @_ == 2; + return (shift)->[%d] = \@_; + } + } + }, map(perlstring($_), $field, $class), $n, $n; +} + +1; + +__END__ + +=head1 NAME + +Class::Accessor::Faster - Even faster, but less expandable, accessors + +=head1 SYNOPSIS + + package Foo; + use base qw(Class::Accessor::Faster); + +=head1 DESCRIPTION + +This is a faster but less expandable version of Class::Accessor::Fast. + +Class::Accessor's generated accessors require two method calls to accomplish +their task (one for the accessor, another for get() or set()). + +Class::Accessor::Fast eliminates calling set()/get() and does the access itself, +resulting in a somewhat faster accessor. + +Class::Accessor::Faster uses an array reference underneath to be faster. + +Read the documentation for Class::Accessor for more info. + +=head1 AUTHORS + +Copyright 2017 Marty Pauley + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. That means either (a) the GNU General Public +License or (b) the Artistic License. + +=head1 SEE ALSO + +L + +=cut Index: synthetic_sim/perl_lib/Class/Accessor.pm =================================================================== --- synthetic_sim/perl_lib/Class/Accessor.pm (nonexistent) +++ synthetic_sim/perl_lib/Class/Accessor.pm (revision 56) @@ -0,0 +1,742 @@ +package Class::Accessor; +require 5.00502; +use strict; +$Class::Accessor::VERSION = '0.51'; + +sub new { + return bless + defined $_[1] + ? {%{$_[1]}} # make a copy of $fields. + : {}, + ref $_[0] || $_[0]; +} + +sub mk_accessors { + my($self, @fields) = @_; + + $self->_mk_accessors('rw', @fields); +} + +if (eval { require Sub::Name }) { + Sub::Name->import; +} + +{ + no strict 'refs'; + + sub import { + my ($class, @what) = @_; + my $caller = caller; + for (@what) { + if (/^(?:antlers|moose-?like)$/i) { + *{"${caller}::has"} = sub { + my ($f, %args) = @_; + $caller->_mk_accessors(($args{is}||"rw"), $f); + }; + *{"${caller}::extends"} = sub { + @{"${caller}::ISA"} = @_; + unless (grep $_->can("_mk_accessors"), @_) { + push @{"${caller}::ISA"}, $class; + } + }; + # we'll use their @ISA as a default, in case it happens to be + # set already + &{"${caller}::extends"}(@{"${caller}::ISA"}); + } + } + } + + sub follow_best_practice { + my($self) = @_; + my $class = ref $self || $self; + *{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for; + *{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for; + } + + sub _mk_accessors { + my($self, $access, @fields) = @_; + my $class = ref $self || $self; + my $ra = $access eq 'rw' || $access eq 'ro'; + my $wa = $access eq 'rw' || $access eq 'wo'; + + foreach my $field (@fields) { + my $accessor_name = $self->accessor_name_for($field); + my $mutator_name = $self->mutator_name_for($field); + if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) { + $self->_carp("Having a data accessor named DESTROY in '$class' is unwise."); + } + if ($accessor_name eq $mutator_name) { + my $accessor; + if ($ra && $wa) { + $accessor = $self->make_accessor($field); + } elsif ($ra) { + $accessor = $self->make_ro_accessor($field); + } else { + $accessor = $self->make_wo_accessor($field); + } + my $fullname = "${class}::$accessor_name"; + my $subnamed = 0; + unless (defined &{$fullname}) { + subname($fullname, $accessor) if defined &subname; + $subnamed = 1; + *{$fullname} = $accessor; + } + if ($accessor_name eq $field) { + # the old behaviour + my $alias = "${class}::_${field}_accessor"; + subname($alias, $accessor) if defined &subname and not $subnamed; + *{$alias} = $accessor unless defined &{$alias}; + } + } else { + my $fullaccname = "${class}::$accessor_name"; + my $fullmutname = "${class}::$mutator_name"; + if ($ra and not defined &{$fullaccname}) { + my $accessor = $self->make_ro_accessor($field); + subname($fullaccname, $accessor) if defined &subname; + *{$fullaccname} = $accessor; + } + if ($wa and not defined &{$fullmutname}) { + my $mutator = $self->make_wo_accessor($field); + subname($fullmutname, $mutator) if defined &subname; + *{$fullmutname} = $mutator; + } + } + } + } + +} + +sub mk_ro_accessors { + my($self, @fields) = @_; + + $self->_mk_accessors('ro', @fields); +} + +sub mk_wo_accessors { + my($self, @fields) = @_; + + $self->_mk_accessors('wo', @fields); +} + +sub best_practice_accessor_name_for { + my ($class, $field) = @_; + return "get_$field"; +} + +sub best_practice_mutator_name_for { + my ($class, $field) = @_; + return "set_$field"; +} + +sub accessor_name_for { + my ($class, $field) = @_; + return $field; +} + +sub mutator_name_for { + my ($class, $field) = @_; + return $field; +} + +sub set { + my($self, $key) = splice(@_, 0, 2); + + if(@_ == 1) { + $self->{$key} = $_[0]; + } + elsif(@_ > 1) { + $self->{$key} = [@_]; + } + else { + $self->_croak("Wrong number of arguments received"); + } +} + +sub get { + my $self = shift; + + if(@_ == 1) { + return $self->{$_[0]}; + } + elsif( @_ > 1 ) { + return @{$self}{@_}; + } + else { + $self->_croak("Wrong number of arguments received"); + } +} + +sub make_accessor { + my ($class, $field) = @_; + + return sub { + my $self = shift; + + if(@_) { + return $self->set($field, @_); + } else { + return $self->get($field); + } + }; +} + +sub make_ro_accessor { + my($class, $field) = @_; + + return sub { + my $self = shift; + + if (@_) { + my $caller = caller; + $self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'"); + } + else { + return $self->get($field); + } + }; +} + +sub make_wo_accessor { + my($class, $field) = @_; + + return sub { + my $self = shift; + + unless (@_) { + my $caller = caller; + $self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'"); + } + else { + return $self->set($field, @_); + } + }; +} + + +use Carp (); + +sub _carp { + my ($self, $msg) = @_; + Carp::carp($msg || $self); + return; +} + +sub _croak { + my ($self, $msg) = @_; + Carp::croak($msg || $self); + return; +} + +1; + +__END__ + +=head1 NAME + + Class::Accessor - Automated accessor generation + +=head1 SYNOPSIS + + package Foo; + use base qw(Class::Accessor); + Foo->follow_best_practice; + Foo->mk_accessors(qw(name role salary)); + + # or if you prefer a Moose-like interface... + + package Foo; + use Class::Accessor "antlers"; + has name => ( is => "rw", isa => "Str" ); + has role => ( is => "rw", isa => "Str" ); + has salary => ( is => "rw", isa => "Num" ); + + # Meanwhile, in a nearby piece of code! + # Class::Accessor provides new(). + my $mp = Foo->new({ name => "Marty", role => "JAPH" }); + + my $job = $mp->role; # gets $mp->{role} + $mp->salary(400000); # sets $mp->{salary} = 400000 # I wish + + # like my @info = @{$mp}{qw(name role)} + my @info = $mp->get(qw(name role)); + + # $mp->{salary} = 400000 + $mp->set('salary', 400000); + + +=head1 DESCRIPTION + +This module automagically generates accessors/mutators for your class. + +Most of the time, writing accessors is an exercise in cutting and +pasting. You usually wind up with a series of methods like this: + + sub name { + my $self = shift; + if(@_) { + $self->{name} = $_[0]; + } + return $self->{name}; + } + + sub salary { + my $self = shift; + if(@_) { + $self->{salary} = $_[0]; + } + return $self->{salary}; + } + + # etc... + +One for each piece of data in your object. While some will be unique, +doing value checks and special storage tricks, most will simply be +exercises in repetition. Not only is it Bad Style to have a bunch of +repetitious code, but it's also simply not lazy, which is the real +tragedy. + +If you make your module a subclass of Class::Accessor and declare your +accessor fields with mk_accessors() then you'll find yourself with a +set of automatically generated accessors which can even be +customized! + +The basic set up is very simple: + + package Foo; + use base qw(Class::Accessor); + Foo->mk_accessors( qw(far bar car) ); + +Done. Foo now has simple far(), bar() and car() accessors +defined. + +Alternatively, if you want to follow Damian's I guidelines +you can use: + + package Foo; + use base qw(Class::Accessor); + Foo->follow_best_practice; + Foo->mk_accessors( qw(far bar car) ); + +B you must call C before calling C. + +=head2 Moose-like + +By popular demand we now have a simple Moose-like interface. You can now do: + + package Foo; + use Class::Accessor "antlers"; + has far => ( is => "rw" ); + has bar => ( is => "rw" ); + has car => ( is => "rw" ); + +Currently only the C attribute is supported. + +=head1 CONSTRUCTOR + +Class::Accessor provides a basic constructor, C. It generates a +hash-based object and can be called as either a class method or an +object method. + +=head2 new + + my $obj = Foo->new; + my $obj = $other_obj->new; + + my $obj = Foo->new(\%fields); + my $obj = $other_obj->new(\%fields); + +It takes an optional %fields hash which is used to initialize the +object (handy if you use read-only accessors). The fields of the hash +correspond to the names of your accessors, so... + + package Foo; + use base qw(Class::Accessor); + Foo->mk_accessors('foo'); + + my $obj = Foo->new({ foo => 42 }); + print $obj->foo; # 42 + +however %fields can contain anything, new() will shove them all into +your object. + +=head1 MAKING ACCESSORS + +=head2 follow_best_practice + +In Damian's Perl Best Practices book he recommends separate get and set methods +with the prefix set_ and get_ to make it explicit what you intend to do. If you +want to create those accessor methods instead of the default ones, call: + + __PACKAGE__->follow_best_practice + +B you call any of the accessor-making methods. + +=head2 accessor_name_for / mutator_name_for + +You may have your own crazy ideas for the names of the accessors, so you can +make those happen by overriding C and C in +your subclass. (I copied that idea from Class::DBI.) + +=head2 mk_accessors + + __PACKAGE__->mk_accessors(@fields); + +This creates accessor/mutator methods for each named field given in +@fields. Foreach field in @fields it will generate two accessors. +One called "field()" and the other called "_field_accessor()". For +example: + + # Generates foo(), _foo_accessor(), bar() and _bar_accessor(). + __PACKAGE__->mk_accessors(qw(foo bar)); + +See L +for details. + +=head2 mk_ro_accessors + + __PACKAGE__->mk_ro_accessors(@read_only_fields); + +Same as mk_accessors() except it will generate read-only accessors +(ie. true accessors). If you attempt to set a value with these +accessors it will throw an exception. It only uses get() and not +set(). + + package Foo; + use base qw(Class::Accessor); + Foo->mk_ro_accessors(qw(foo bar)); + + # Let's assume we have an object $foo of class Foo... + print $foo->foo; # ok, prints whatever the value of $foo->{foo} is + $foo->foo(42); # BOOM! Naughty you. + + +=head2 mk_wo_accessors + + __PACKAGE__->mk_wo_accessors(@write_only_fields); + +Same as mk_accessors() except it will generate write-only accessors +(ie. mutators). If you attempt to read a value with these accessors +it will throw an exception. It only uses set() and not get(). + +B I'm not entirely sure why this is useful, but I'm sure someone +will need it. If you've found a use, let me know. Right now it's here +for orthogonality and because it's easy to implement. + + package Foo; + use base qw(Class::Accessor); + Foo->mk_wo_accessors(qw(foo bar)); + + # Let's assume we have an object $foo of class Foo... + $foo->foo(42); # OK. Sets $self->{foo} = 42 + print $foo->foo; # BOOM! Can't read from this accessor. + +=head1 Moose! + +If you prefer a Moose-like interface to create accessors, you can use C by +importing this module like this: + + use Class::Accessor "antlers"; + +or + + use Class::Accessor "moose-like"; + +Then you can declare accessors like this: + + has alpha => ( is => "rw", isa => "Str" ); + has beta => ( is => "ro", isa => "Str" ); + has gamma => ( is => "wo", isa => "Str" ); + +Currently only the C attribute is supported. And our C also supports +the "wo" value to make a write-only accessor. + +If you are using the Moose-like interface then you should use the C +rather than tweaking your C<@ISA> directly. Basically, replace + + @ISA = qw/Foo Bar/; + +with + + extends(qw/Foo Bar/); + +=head1 DETAILS + +An accessor generated by Class::Accessor looks something like +this: + + # Your foo may vary. + sub foo { + my($self) = shift; + if(@_) { # set + return $self->set('foo', @_); + } + else { + return $self->get('foo'); + } + } + +Very simple. All it does is determine if you're wanting to set a +value or get a value and calls the appropriate method. +Class::Accessor provides default get() and set() methods which +your class can override. They're detailed later. + +=head2 Modifying the behavior of the accessor + +Rather than actually modifying the accessor itself, it is much more +sensible to simply override the two key methods which the accessor +calls. Namely set() and get(). + +If you -really- want to, you can override make_accessor(). + +=head2 set + + $obj->set($key, $value); + $obj->set($key, @values); + +set() defines how generally one stores data in the object. + +override this method to change how data is stored by your accessors. + +=head2 get + + $value = $obj->get($key); + @values = $obj->get(@keys); + +get() defines how data is retrieved from your objects. + +override this method to change how it is retrieved. + +=head2 make_accessor + + $accessor = __PACKAGE__->make_accessor($field); + +Generates a subroutine reference which acts as an accessor for the given +$field. It calls get() and set(). + +If you wish to change the behavior of your accessors, try overriding +get() and set() before you start mucking with make_accessor(). + +=head2 make_ro_accessor + + $read_only_accessor = __PACKAGE__->make_ro_accessor($field); + +Generates a subroutine reference which acts as a read-only accessor for +the given $field. It only calls get(). + +Override get() to change the behavior of your accessors. + +=head2 make_wo_accessor + + $write_only_accessor = __PACKAGE__->make_wo_accessor($field); + +Generates a subroutine reference which acts as a write-only accessor +(mutator) for the given $field. It only calls set(). + +Override set() to change the behavior of your accessors. + +=head1 EXCEPTIONS + +If something goes wrong Class::Accessor will warn or die by calling Carp::carp +or Carp::croak. If you don't like this you can override _carp() and _croak() in +your subclass and do whatever else you want. + +=head1 EFFICIENCY + +Class::Accessor does not employ an autoloader, thus it is much faster +than you'd think. Its generated methods incur no special penalty over +ones you'd write yourself. + + accessors: + Rate Basic Fast Faster Direct + Basic 367589/s -- -51% -55% -89% + Fast 747964/s 103% -- -9% -77% + Faster 819199/s 123% 10% -- -75% + Direct 3245887/s 783% 334% 296% -- + + mutators: + Rate Acc Fast Faster Direct + Acc 265564/s -- -54% -63% -91% + Fast 573439/s 116% -- -21% -80% + Faster 724710/s 173% 26% -- -75% + Direct 2860979/s 977% 399% 295% -- + +Class::Accessor::Fast is faster than methods written by an average programmer +(where "average" is based on Schwern's example code). + +Class::Accessor is slower than average, but more flexible. + +Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an +array internally, not a hash. This could be a good or bad feature depending on +your point of view. + +Direct hash access is, of course, much faster than all of these, but it +provides no encapsulation. + +Of course, it's not as simple as saying "Class::Accessor is slower than +average". These are benchmarks for a simple accessor. If your accessors do +any sort of complicated work (such as talking to a database or writing to a +file) the time spent doing that work will quickly swamp the time spend just +calling the accessor. In that case, Class::Accessor and the ones you write +will be roughly the same speed. + + +=head1 EXAMPLES + +Here's an example of generating an accessor for every public field of +your class. + + package Altoids; + + use base qw(Class::Accessor Class::Fields); + use fields qw(curiously strong mints); + Altoids->mk_accessors( Altoids->show_fields('Public') ); + + sub new { + my $proto = shift; + my $class = ref $proto || $proto; + return fields::new($class); + } + + my Altoids $tin = Altoids->new; + + $tin->curiously('Curiouser and curiouser'); + print $tin->{curiously}; # prints 'Curiouser and curiouser' + + + # Subclassing works, too. + package Mint::Snuff; + use base qw(Altoids); + + my Mint::Snuff $pouch = Mint::Snuff->new; + $pouch->strong('Blow your head off!'); + print $pouch->{strong}; # prints 'Blow your head off!' + + +Here's a simple example of altering the behavior of your accessors. + + package Foo; + use base qw(Class::Accessor); + Foo->mk_accessors(qw(this that up down)); + + sub get { + my $self = shift; + + # Note every time someone gets some data. + print STDERR "Getting @_\n"; + + $self->SUPER::get(@_); + } + + sub set { + my ($self, $key) = splice(@_, 0, 2); + + # Note every time someone sets some data. + print STDERR "Setting $key to @_\n"; + + $self->SUPER::set($key, @_); + } + + +=head1 CAVEATS AND TRICKS + +Class::Accessor has to do some internal wackiness to get its +job done quickly and efficiently. Because of this, there's a few +tricks and traps one must know about. + +Hey, nothing's perfect. + +=head2 Don't make a field called DESTROY + +This is bad. Since DESTROY is a magical method it would be bad for us +to define an accessor using that name. Class::Accessor will +carp if you try to use it with a field named "DESTROY". + +=head2 Overriding autogenerated accessors + +You may want to override the autogenerated accessor with your own, yet +have your custom accessor call the default one. For instance, maybe +you want to have an accessor which checks its input. Normally, one +would expect this to work: + + package Foo; + use base qw(Class::Accessor); + Foo->mk_accessors(qw(email this that whatever)); + + # Only accept addresses which look valid. + sub email { + my($self) = shift; + my($email) = @_; + + if( @_ ) { # Setting + require Email::Valid; + unless( Email::Valid->address($email) ) { + carp("$email doesn't look like a valid address."); + return; + } + } + + return $self->SUPER::email(@_); + } + +There's a subtle problem in the last example, and it's in this line: + + return $self->SUPER::email(@_); + +If we look at how Foo was defined, it called mk_accessors() which +stuck email() right into Foo's namespace. There *is* no +SUPER::email() to delegate to! Two ways around this... first is to +make a "pure" base class for Foo. This pure class will generate the +accessors and provide the necessary super class for Foo to use: + + package Pure::Organic::Foo; + use base qw(Class::Accessor); + Pure::Organic::Foo->mk_accessors(qw(email this that whatever)); + + package Foo; + use base qw(Pure::Organic::Foo); + +And now Foo::email() can override the generated +Pure::Organic::Foo::email() and use it as SUPER::email(). + +This is probably the most obvious solution to everyone but me. +Instead, what first made sense to me was for mk_accessors() to define +an alias of email(), _email_accessor(). Using this solution, +Foo::email() would be written with: + + return $self->_email_accessor(@_); + +instead of the expected SUPER::email(). + + +=head1 AUTHORS + +Copyright 2017 Marty Pauley + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. That means either (a) the GNU General Public +License or (b) the Artistic License. + +=head2 ORIGINAL AUTHOR + +Michael G Schwern + +=head2 THANKS + +Liz and RUZ for performance tweaks. + +Tels, for his big feature request/bug report. + +Various presenters at YAPC::Asia 2009 for criticising the non-Moose interface. + +=head1 SEE ALSO + +See L and L if speed is more +important than flexibility. + +These are some modules which do similar things in different ways +L, L, L, +L, L, L, L + +See L for an example of this module in use. + +=cut Index: synthetic_sim/perl_lib/Exporter/Tiny.pm =================================================================== --- synthetic_sim/perl_lib/Exporter/Tiny.pm (nonexistent) +++ synthetic_sim/perl_lib/Exporter/Tiny.pm (revision 56) @@ -0,0 +1,508 @@ +package Exporter::Tiny; + +use 5.006001; +use strict; +use warnings; no warnings qw(void once uninitialized numeric redefine); + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.002002'; +our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >; + +sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak } +sub _carp ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp } + +my $_process_optlist = sub +{ + my $class = shift; + my ($global_opts, $opts, $want, $not_want) = @_; + + while (@$opts) + { + my $opt = shift @{$opts}; + my ($name, $value) = @$opt; + + ($name =~ m{\A\!(/.+/[msixpodual]*)\z}) ? + do { + my @not = $class->_exporter_expand_regexp($1, $value, $global_opts); + ++$not_want->{$_->[0]} for @not; + } : + ($name =~ m{\A\!(.+)\z}) ? + (++$not_want->{$1}) : + ($name =~ m{\A[:-](.+)\z}) ? + push(@$opts, $class->_exporter_expand_tag($1, $value, $global_opts)) : + ($name =~ m{\A/.+/[msixpodual]*\z}) ? + push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) : + # else ? + push(@$want, $opt); + } +}; + +sub import +{ + my $class = shift; + my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () }; + $global_opts->{into} = caller unless exists $global_opts->{into}; + + my @want; + my %not_want; $global_opts->{not} = \%not_want; + my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} }; + my $opts = mkopt(\@args); + $class->$_process_optlist($global_opts, $opts, \@want, \%not_want); + + my $permitted = $class->_exporter_permitted_regexp($global_opts); + $class->_exporter_validate_opts($global_opts); + + for my $wanted (@want) + { + next if $not_want{$wanted->[0]}; + + my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted); + $class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_}) + for keys %symbols; + } +} + +sub unimport +{ + my $class = shift; + my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () }; + $global_opts->{into} = caller unless exists $global_opts->{into}; + $global_opts->{is_unimport} = 1; + + my @want; + my %not_want; $global_opts->{not} = \%not_want; + my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) }; + my $opts = mkopt(\@args); + $class->$_process_optlist($global_opts, $opts, \@want, \%not_want); + + my $permitted = $class->_exporter_permitted_regexp($global_opts); + $class->_exporter_validate_unimport_opts($global_opts); + + my $expando = $class->can('_exporter_expand_sub'); + $expando = undef if $expando == \&_exporter_expand_sub; + + for my $wanted (@want) + { + next if $not_want{$wanted->[0]}; + + if ($wanted->[1]) + { + _carp("Passing options to unimport '%s' makes no sense", $wanted->[0]) + unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]}); + } + + my %symbols = defined($expando) + ? $class->$expando(@$wanted, $global_opts, $permitted) + : ($wanted->[0] => sub { "dummy" }); + $class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts) + for keys %symbols; + } +} + +# Called once per import/unimport, passed the "global" import options. +# Expected to validate the options and carp or croak if there are problems. +# Can also take the opportunity to do other stuff if needed. +# +sub _exporter_validate_opts { 1 } +sub _exporter_validate_unimport_opts { 1 } + +# Called after expanding a tag or regexp to merge the tag's options with +# any sub-specific options. +# +sub _exporter_merge_opts +{ + my $class = shift; + my ($tag_opts, $global_opts, @stuff) = @_; + + $tag_opts = {} unless ref($tag_opts) eq q(HASH); + _croak('Cannot provide an -as option for tags') + if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE'; + + my $optlist = mkopt(\@stuff); + for my $export (@$optlist) + { + next if defined($export->[1]) && ref($export->[1]) ne q(HASH); + + my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts ); + $sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix}) + if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix}); + $sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix}) + if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix}); + $export->[1] = \%sub_opts; + } + return @$optlist; +} + +# Given a tag name, looks it up in %EXPORT_TAGS and returns the list of +# associated functions. The default implementation magically handles tags +# "all" and "default". The default implementation interprets any undefined +# tags as being global options. +# +sub _exporter_expand_tag +{ + no strict qw(refs); + + my $class = shift; + my ($name, $value, $globals) = @_; + my $tags = \%{"$class\::EXPORT_TAGS"}; + + return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_)) + if ref($tags->{$name}) eq q(CODE); + + return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}}) + if exists $tags->{$name}; + + return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"}) + if $name eq 'all'; + + return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}) + if $name eq 'default'; + + $globals->{$name} = $value || 1; + return; +} + +# Given a regexp-like string, looks it up in @EXPORT_OK and returns the +# list of matching functions. +# +sub _exporter_expand_regexp +{ + no strict qw(refs); + our %TRACKED; + + my $class = shift; + my ($name, $value, $globals) = @_; + my $compiled = eval("qr$name"); + + my @possible = $globals->{is_unimport} + ? keys( %{$TRACKED{$class}{$globals->{into}}} ) + : @{"$class\::EXPORT_OK"}; + + $class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible); +} + +# Helper for _exporter_expand_sub. Returns a regexp matching all subs in +# the exporter package which are available for export. +# +sub _exporter_permitted_regexp +{ + no strict qw(refs); + my $class = shift; + my $re = join "|", map quotemeta, sort { + length($b) <=> length($a) or $a cmp $b + } @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"}; + qr{^(?:$re)$}ms; +} + +# Given a sub name, returns a hash of subs to install (usually just one sub). +# Keys are sub names, values are coderefs. +# +sub _exporter_expand_sub +{ + my $class = shift; + my ($name, $value, $globals, $permitted) = @_; + $permitted ||= $class->_exporter_permitted_regexp($globals); + + no strict qw(refs); + + my $sigil = "&"; + if ($name =~ /\A([&\$\%\@\*])(.+)\z/) { + $sigil = $1; + $name = $2; + if ($sigil eq '*') { + _croak("Cannot export symbols with a * sigil"); + } + } + my $sigilname = $sigil eq '&' ? $name : "$sigil$name"; + + if ($sigilname =~ $permitted) + { + my $generatorprefix = { + '&' => "_generate_", + '$' => "_generateScalar_", + '@' => "_generateArray_", + '%' => "_generateHash_", + }->{$sigil}; + + my $generator = $class->can("$generatorprefix$name"); + return $sigilname => $class->$generator($sigilname, $value, $globals) if $generator; + + my $sub = $class->can($name); + return $sigilname => $sub if $sub; + + # Could do this more cleverly, but this works. + if ($sigil ne '&') { + my $evalled = eval "\\${sigil}${class}::${name}"; + return $sigilname => $evalled if $evalled; + } + } + + $class->_exporter_fail(@_); +} + +# Called by _exporter_expand_sub if it is unable to generate a key-value +# pair for a sub. +# +sub _exporter_fail +{ + my $class = shift; + my ($name, $value, $globals) = @_; + return if $globals->{is_unimport}; + _croak("Could not find sub '%s' exported by %s", $name, $class); +} + +# Actually performs the installation of the sub into the target package. This +# also handles renaming the sub. +# +sub _exporter_install_sub +{ + my $class = shift; + my ($name, $value, $globals, $sym) = @_; + + my $into = $globals->{into}; + my $installer = $globals->{installer} || $globals->{exporter}; + + $name = + ref $globals->{as} ? $globals->{as}->($name) : + ref $value->{-as} ? $value->{-as}->($name) : + exists $value->{-as} ? $value->{-as} : + $name; + + return unless defined $name; + + my $sigil = "&"; + unless (ref($name)) { + if ($name =~ /\A([&\$\%\@\*])(.+)\z/) { + $sigil = $1; + $name = $2; + if ($sigil eq '*') { + _croak("Cannot export symbols with a * sigil"); + } + } + my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q(); + my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q(); + $name = "$prefix$name$suffix"; + } + + my $sigilname = $sigil eq '&' ? $name : "$sigil$name"; + +# if ({qw/$ SCALAR @ ARRAY % HASH & CODE/}->{$sigil} ne ref($sym)) { +# warn $sym; +# warn $sigilname; +# _croak("Reference type %s does not match sigil %s", ref($sym), $sigil); +# } + + return ($$name = $sym) if ref($name) eq q(SCALAR); + return ($into->{$sigilname} = $sym) if ref($into) eq q(HASH); + + no strict qw(refs); + our %TRACKED; + + if (ref($sym) eq 'CODE' and exists &{"$into\::$name"} and \&{"$into\::$name"} != $sym) + { + my ($level) = grep defined, $value->{-replace}, $globals->{replace}, q(0); + my $action = { + carp => \&_carp, + 0 => \&_carp, + '' => \&_carp, + warn => \&_carp, + nonfatal => \&_carp, + croak => \&_croak, + fatal => \&_croak, + die => \&_croak, + }->{$level} || sub {}; + + # Don't complain about double-installing the same sub. This isn't ideal + # because the same named sub might be generated in two different ways. + $action = sub {} if $TRACKED{$class}{$into}{$sigilname}; + + $action->( + $action == \&_croak + ? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s" + : "Overwriting existing sub '%s::%s' with sub '%s' exported by %s", + $into, + $name, + $_[0], + $class, + ); + } + + $TRACKED{$class}{$into}{$sigilname} = $sym; + + no warnings qw(prototype); + $installer + ? $installer->($globals, [$sigilname, $sym]) + : (*{"$into\::$name"} = $sym); +} + +sub _exporter_uninstall_sub +{ + our %TRACKED; + my $class = shift; + my ($name, $value, $globals, $sym) = @_; + my $into = $globals->{into}; + ref $into and return; + + no strict qw(refs); + + my $sigil = "&"; + if ($name =~ /\A([&\$\%\@\*])(.+)\z/) { + $sigil = $1; + $name = $2; + if ($sigil eq '*') { + _croak("Cannot export symbols with a * sigil"); + } + } + my $sigilname = $sigil eq '&' ? $name : "$sigil$name"; + + if ($sigil ne '&') { + _croak("Unimporting non-code symbols not supported yet"); + } + + # Cowardly refuse to uninstall a sub that differs from the one + # we installed! + my $our_coderef = $TRACKED{$class}{$into}{$name}; + my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1; + return unless $our_coderef == $cur_coderef; + + my $stash = \%{"$into\::"}; + my $old = delete $stash->{$name}; + my $full_name = join('::', $into, $name); + foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE + { + next unless defined(*{$old}{$type}); + *$full_name = *{$old}{$type}; + } + + delete $TRACKED{$class}{$into}{$name}; +} + +sub mkopt +{ + my $in = shift or return []; + my @out; + + $in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)] + if ref($in) eq q(HASH); + + for (my $i = 0; $i < @$in; $i++) + { + my $k = $in->[$i]; + my $v; + + ($i == $#$in) ? ($v = undef) : + !defined($in->[$i+1]) ? (++$i, ($v = undef)) : + !ref($in->[$i+1]) ? ($v = undef) : + ($v = $in->[++$i]); + + push @out, [ $k => $v ]; + } + + \@out; +} + +sub mkopt_hash +{ + my $in = shift or return; + my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) }; + \%out; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords frobnicate greps regexps + +=head1 NAME + +Exporter::Tiny - an exporter with the features of Sub::Exporter but only core dependencies + +=head1 SYNOPSIS + + package MyUtils; + use base "Exporter::Tiny"; + our @EXPORT = qw(frobnicate); + sub frobnicate { ... } + 1; + + package MyScript; + use MyUtils "frobnicate" => { -as => "frob" }; + print frob(42); + exit; + +=head1 DESCRIPTION + +Exporter::Tiny supports many of Sub::Exporter's external-facing features +including renaming imported functions with the C<< -as >>, C<< -prefix >> and +C<< -suffix >> options; explicit destinations with the C<< into >> option; +and alternative installers with the C<< installer >> option. But it's written +in only about 40% as many lines of code and with zero non-core dependencies. + +Its internal-facing interface is closer to Exporter.pm, with configuration +done through the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >> +package variables. + +If you are trying to B a module that inherits from Exporter::Tiny, +then look at: + +=over + +=item * + +L + +=item * + +L + +=back + +If you are trying to B a module that inherits from Exporter::Tiny, +then look at: + +=over + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SUPPORT + +B<< IRC: >> support is available through in the I<< #moops >> channel +on L. + +=head1 SEE ALSO + +Simplified interface to this module: L. + +Other interesting exporters: L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017 by Toby Inkster. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=head1 DISCLAIMER OF WARRANTIES + +THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + Index: synthetic_sim/perl_lib/File/Copy/Recursive.pm =================================================================== --- synthetic_sim/perl_lib/File/Copy/Recursive.pm (nonexistent) +++ synthetic_sim/perl_lib/File/Copy/Recursive.pm (revision 56) @@ -0,0 +1,808 @@ +package File::Copy::Recursive; + +use strict; + +BEGIN { + # Keep older versions of Perl from trying to use lexical warnings + $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006; +} +use warnings; + +use Carp; +use File::Copy; +use File::Spec; #not really needed because File::Copy already gets it, but for good measure :) +use Cwd (); + +use vars qw( + @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink + $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir + $CondCopy $BdTrgWrn $SkipFlop $DirPerms +); + +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob); + +$VERSION = '0.45'; + +$MaxDepth = 0; +$KeepMode = 1; +$CPRFComp = 0; +$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0; +$PFSCheck = 1; +$RemvBase = 0; +$NoFtlPth = 0; +$ForcePth = 0; +$CopyLoop = 0; +$RMTrgFil = 0; +$RMTrgDir = 0; +$CondCopy = {}; +$BdTrgWrn = 0; +$SkipFlop = 0; +$DirPerms = 0777; + +my $samecheck = sub { + return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders... + return if @_ != 2 || !defined $_[0] || !defined $_[1]; + return if $_[0] eq $_[1]; + + my $one = ''; + if ($PFSCheck) { + $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || ''; + my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || ''; + if ( $one eq $two && $one ) { + carp "$_[0] and $_[1] are identical"; + return; + } + } + + if ( -d $_[0] && !$CopyLoop ) { + $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one; + my $abs = File::Spec->rel2abs( $_[1] ); + my @pth = File::Spec->splitdir($abs); + while (@pth) { + if ( $pth[-1] eq '..' ) { # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right? + pop @pth; + pop @pth unless -l File::Spec->catdir(@pth); + next; + } + my $cur = File::Spec->catdir(@pth); + last if !$cur; # probably not necessary, but nice to have just in case :) + my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || ''; + if ( $one eq $two && $one ) { + + # $! = 62; # Too many levels of symbolic links + carp "Caught Deep Recursion Condition: $_[0] contains $_[1]"; + return; + } + + pop @pth; + } + } + + return 1; +}; + +my $glob = sub { + my ( $do, $src_glob, @args ) = @_; + + local $CPRFComp = 1; + require File::Glob; + + my @rt; + for my $path ( File::Glob::bsd_glob($src_glob) ) { + my @call = [ $do->( $path, @args ) ] or return; + push @rt, \@call; + } + + return @rt; +}; + +my $move = sub { + my $fl = shift; + my @x; + if ($fl) { + @x = fcopy(@_) or return; + } + else { + @x = dircopy(@_) or return; + } + if (@x) { + if ($fl) { + unlink $_[0] or return; + } + else { + pathrmdir( $_[0] ) or return; + } + if ($RemvBase) { + my ( $volm, $path ) = File::Spec->splitpath( $_[0] ); + pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return; + } + } + return wantarray ? @x : $x[0]; +}; + +my $ok_todo_asper_condcopy = sub { + my $org = shift; + my $copy = 1; + if ( exists $CondCopy->{$org} ) { + if ( $CondCopy->{$org}{'md5'} ) { + + } + if ($copy) { + + } + } + return $copy; +}; + +sub fcopy { + $samecheck->(@_) or return; + if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) { + my $trg = $_[1]; + if ( -d $trg ) { + my @trgx = File::Spec->splitpath( $_[0] ); + $trg = File::Spec->catfile( $_[1], $trgx[$#trgx] ); + } + $samecheck->( $_[0], $trg ) or return; + if ( -e $trg ) { + if ( $RMTrgFil == 1 ) { + unlink $trg or carp "\$RMTrgFil failed: $!"; + } + else { + unlink $trg or return; + } + } + } + my ( $volm, $path ) = File::Spec->splitpath( $_[1] ); + if ( $path && !-d $path ) { + pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth ); + } + if ( -l $_[0] && $CopyLink ) { + my $target = readlink( shift() ); + ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does + carp "Copying a symlink ($_[0]) whose target does not exist" + if !-e $target && $BdTrgWrn; + my $new = shift(); + unlink $new if -l $new; + symlink( $target, $new ) or return; + } + elsif ( -d $_[0] && -f $_[1] ) { + return; + } + else { + return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866 + copy(@_) or return; + + my @base_file = File::Spec->splitpath( $_[0] ); + my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1]; + + chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode; + } + return wantarray ? ( 1, 0, 0 ) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings +} + +sub rcopy { + if ( -l $_[0] && $CopyLink ) { + goto &fcopy; + } + + goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*'; + goto &fcopy; +} + +sub rcopy_glob { + $glob->( \&rcopy, @_ ); +} + +sub dircopy { + if ( $RMTrgDir && -d $_[1] ) { + if ( $RMTrgDir == 1 ) { + pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!"; + } + else { + pathrmdir( $_[1] ) or return; + } + } + my $globstar = 0; + my $_zero = $_[0]; + my $_one = $_[1]; + if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) { + $globstar = 1; + $_zero = substr( $_zero, 0, ( length($_zero) - 1 ) ); + } + + $samecheck->( $_zero, $_[1] ) or return; + if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { + $! = 20; + return; + } + + if ( !-d $_[1] ) { + pathmk( $_[1], $NoFtlPth ) or return; + } + else { + if ( $CPRFComp && !$globstar ) { + my @parts = File::Spec->splitdir($_zero); + while ( $parts[$#parts] eq '' ) { pop @parts; } + $_one = File::Spec->catdir( $_[1], $parts[$#parts] ); + } + } + my $baseend = $_one; + my $level = 0; + my $filen = 0; + my $dirn = 0; + + my $recurs; #must be my()ed before sub {} since it calls itself + $recurs = sub { + my ( $str, $end, $buf ) = @_; + $filen++ if $end eq $baseend; + $dirn++ if $end eq $baseend; + + $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0'; + mkdir( $end, $DirPerms ) or return if !-d $end; + if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) { + chmod scalar( ( stat($str) )[2] ), $end if $KeepMode; + return ( $filen, $dirn, $level ) if wantarray; + return $filen; + } + + $level++; + + my @files; + if ( $] < 5.006 ) { + opendir( STR_DH, $str ) or return; + @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) ); + closedir STR_DH; + } + else { + opendir( my $str_dh, $str ) or return; + @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) ); + closedir $str_dh; + } + + for my $file (@files) { + my ($file_ut) = $file =~ m{ (.*) }xms; + my $org = File::Spec->catfile( $str, $file_ut ); + my $new = File::Spec->catfile( $end, $file_ut ); + if ( -l $org && $CopyLink ) { + my $target = readlink($org); + ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does + carp "Copying a symlink ($org) whose target does not exist" + if !-e $target && $BdTrgWrn; + unlink $new if -l $new; + symlink( $target, $new ) or return; + } + elsif ( -d $org ) { + my $rc; + if ( !-w $org && $KeepMode ) { + local $KeepMode = 0; + $rc = $recurs->( $org, $new, $buf ) if defined $buf; + $rc = $recurs->( $org, $new ) if !defined $buf; + chmod scalar( ( stat($org) )[2] ), $new; + } + else { + $rc = $recurs->( $org, $new, $buf ) if defined $buf; + $rc = $recurs->( $org, $new ) if !defined $buf; + } + if ( !$rc ) { + if ($SkipFlop) { + next; + } + else { + return; + } + } + $filen++; + $dirn++; + } + else { + if ( $ok_todo_asper_condcopy->($org) ) { + if ($SkipFlop) { + fcopy( $org, $new, $buf ) or next if defined $buf; + fcopy( $org, $new ) or next if !defined $buf; + } + else { + fcopy( $org, $new, $buf ) or return if defined $buf; + fcopy( $org, $new ) or return if !defined $buf; + } + chmod scalar( ( stat($org) )[2] ), $new if $KeepMode; + $filen++; + } + } + } + $level--; + chmod scalar( ( stat($str) )[2] ), $end if $KeepMode; + 1; + + }; + + $recurs->( $_zero, $_one, $_[2] ) or return; + return wantarray ? ( $filen, $dirn, $level ) : $filen; +} + +sub fmove { $move->( 1, @_ ) } + +sub rmove { + if ( -l $_[0] && $CopyLink ) { + goto &fmove; + } + + goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*'; + goto &fmove; +} + +sub rmove_glob { + $glob->( \&rmove, @_ ); +} + +sub dirmove { $move->( 0, @_ ) } + +sub pathmk { + my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() ); + my $nofatal = shift; + + $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0'; + + if ( defined($dir) ) { + my (@dirs) = File::Spec->splitdir($dir); + + for ( my $i = 0; $i < scalar(@dirs); $i++ ) { + my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] ); + my $newpth = File::Spec->catpath( $vol, $newdir, "" ); + + mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal; + mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal; + } + } + + if ( defined($file) ) { + my $newpth = File::Spec->catpath( $vol, $dir, $file ); + + mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal; + mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal; + } + + 1; +} + +sub pathempty { + my $pth = shift; + + my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ]; + return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows + + my $starting_point = Cwd::cwd(); + my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ]; + chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!"); + $pth = '.'; + _bail_if_changed( $pth, $orig_dev, $orig_ino ); + + my @names; + my $pth_dh; + if ( $] < 5.006 ) { + opendir( PTH_DH, $pth ) or return; + @names = grep !/^\.\.?$/, readdir(PTH_DH); + closedir PTH_DH; + } + else { + opendir( $pth_dh, $pth ) or return; + @names = grep !/^\.\.?$/, readdir($pth_dh); + closedir $pth_dh; + } + _bail_if_changed( $pth, $orig_dev, $orig_ino ); + + for my $name (@names) { + my ($name_ut) = $name =~ m{ (.*) }xms; + my $flpth = File::Spec->catdir( $pth, $name_ut ); + + if ( -l $flpth ) { + _bail_if_changed( $pth, $orig_dev, $orig_ino ); + unlink $flpth or return; + } + elsif ( -d $flpth ) { + _bail_if_changed( $pth, $orig_dev, $orig_ino ); + pathrmdir($flpth) or return; + } + else { + _bail_if_changed( $pth, $orig_dev, $orig_ino ); + unlink $flpth or return; + } + } + + chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!"); + _bail_if_changed( ".", $starting_dev, $starting_ino ); + + return 1; +} + +sub pathrm { + my ( $path, $force, $nofail ) = @_; + + my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ]; + return 2 if !-d _ || !defined($orig_dev) || !$orig_ino; + + # Manual test (I hate this function :/): + # sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo + if ( $force && File::Spec->file_name_is_absolute($path) ) { + Carp::croak("pathrm() w/ force on abspath is not allowed"); + } + + my @pth = File::Spec->splitdir($path); + + my %fs_check; + my $aggregate_path; + for my $part (@pth) { + $aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part; + $fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ]; + } + + while (@pth) { + my $cur = File::Spec->catdir(@pth); + last if !$cur; # necessary ??? + + if ($force) { + _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] ); + if ( !pathempty($cur) ) { + return unless $nofail; + } + } + _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] ); + if ($nofail) { + rmdir $cur; + } + else { + rmdir $cur or return; + } + pop @pth; + } + + return 1; +} + +sub pathrmdir { + my $dir = shift; + if ( -e $dir ) { + return if !-d $dir; + } + else { + return 2; + } + + my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ]; + return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); + + pathempty($dir) or return; + _bail_if_changed( $dir, $orig_dev, $orig_ino ); + rmdir $dir or return; + + return 1; +} + +sub _bail_if_changed { + my ( $path, $orig_dev, $orig_ino ) = @_; + + my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ]; + + if ( !defined $cur_dev || !defined $cur_ino ) { + $cur_dev ||= "undef(path went away?)"; + $cur_ino ||= "undef(path went away?)"; + } + else { + $path = Cwd::abs_path($path); + } + + if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) { + local $Carp::CarpLevel += 1; + Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting"); + } +} + +1; + +__END__ + +=head1 NAME + +File::Copy::Recursive - Perl extension for recursively copying files and directories + +=head1 SYNOPSIS + + use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove); + + fcopy($orig,$new[,$buf]) or die $!; + rcopy($orig,$new[,$buf]) or die $!; + dircopy($orig,$new[,$buf]) or die $!; + + fmove($orig,$new[,$buf]) or die $!; + rmove($orig,$new[,$buf]) or die $!; + dirmove($orig,$new[,$buf]) or die $!; + + rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!; + rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!; + +=head1 DESCRIPTION + +This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode. + +=head1 EXPORT + +None by default. But you can export all the functions as in the example above and the path* functions if you wish. + +=head2 fcopy() + +This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be. +One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below) +The optional $buf in the synopsis is the same as File::Copy::copy()'s 3rd argument. +This function returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomodate rcopy()'s list context on regular files. (See below for more info) + +=head2 dircopy() + +This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory. +$new is created if necessary (multiple non existent directories is ok (i.e. foo/bar/baz). The script logically and portably creates all of them if necessary). +It attempts to preserve the mode (see Preserving Mode below) and +by default it copies all the way down into the directory (see Managing Depth, below). +If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified. + +This function returns true or false: for true in scalar context it returns the number of files and directories copied, +whereas in list context it returns the number of files and directories, number of directories only, depth level traversed. + + my $num_of_files_and_dirs = dircopy($orig,$new); + my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new); + +Normally it stops and returns if a copy fails. To continue on regardless, set $File::Copy::Recursive::SkipFlop to true. + + local $File::Copy::Recursive::SkipFlop = 1; + +That way it will copy everythging it can in a directory and won't stop because of permissions, etc... + +=head2 rcopy() + +This function will allow you to specify a file *or* a directory. It calls fcopy() if you passed file and dircopy() if you passed a directory. +If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used. +This is important because if it's a directory in list context and there is only the initial directory the return value is 1,1,1. + +=head2 rcopy_glob() + +This function lets you specify a pattern suitable for perl's File::Glob::bsd_glob() as the first argument. Subsequently each path returned by perl's File::Glob::bsd_glob() gets rcopy()ied. + +It returns and array whose items are array refs that contain the return value of each rcopy() call. + +It forces behavior as if $File::Copy::Recursive::CPRFComp is true. + +=head2 fmove() + +Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase. + +=head2 dirmove() + +Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase. + +=head2 rmove() + +Like rcopy() but calls fmove() or dirmove() instead. + +=head2 rmove_glob() + +Like rcopy_glob() but calls rmove() instead of rcopy() + +=head3 $RemvBase + +Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in. + +So if you: + + rmove('foo/bar/baz', '/etc/'); + # "baz" is removed from foo/bar after it is successfully copied to /etc/ + + local $File::Copy::Recursive::Remvbase = 1; + rmove('foo/bar/baz','/etc/'); + # if baz is successfully copied to /etc/ : + # first "baz" is removed from foo/bar + # then "foo/bar is removed via pathrm() + +=head4 $ForcePth + +Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect. + +=head2 Creating and Removing Paths + +=head3 $NoFtlPth + +Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure. + +If its set to true they just silently go about their business regardless. This isn't a good idea but it's there if you want it. + +=head3 $DirPerms + +Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you. + +Any value you set it to should be suitable for oct(). + +=head3 Path functions + +These functions exist solely because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move functions work and use them by themselves if you wish. + +=head4 pathrm() + +Removes a given path recursively. It removes the *entire* path so be careful!!! + +Returns 2 if the given path is not a directory. + + File::Copy::Recursive::pathrm('foo/bar/baz') or die $!; + # foo no longer exists + +Same as: + + rmdir 'foo/bar/baz' or die $!; + rmdir 'foo/bar' or die $!; + rmdir 'foo' or die $!; + +An optional second argument makes it call pathempty() before any rmdir()'s when set to true. + + File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!; + # foo no longer exists + +Same as:PFSCheck + + File::Copy::Recursive::pathempty('foo/bar/baz') or die $!; + rmdir 'foo/bar/baz' or die $!; + File::Copy::Recursive::pathempty('foo/bar/') or die $!; + rmdir 'foo/bar' or die $!; + File::Copy::Recursive::pathempty('foo/') or die $!; + rmdir 'foo' or die $!; + +An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea. + +=head4 pathempty() + +Recursively removes the given directory's contents so it is empty. Returns 2 if the given argument is not a directory, 1 on successfully emptying the directory. + + File::Copy::Recursive::pathempty($pth) or die $!; + # $pth is now an empty directory + +=head4 pathmk() + +Creates a given path recursively. Creates foo/bar/baz even if foo does not exist. + + File::Copy::Recursive::pathmk('foo/bar/baz') or die $!; + +An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea. + +=head4 pathrmdir() + +Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents. +Just removes the top directory the path given instead of the entire path like pathrm(). Returns 2 if the given argument does not exist (i.e. it's already gone). Returns false if it exists but is not a directory. + +=head2 Preserving Mode + +By default a quiet attempt is made to change the new file or directory to the mode of the old one. +To turn this behavior off set + $File::Copy::Recursive::KeepMode +to false; + +=head2 Managing Depth + +You can set the maximum depth a directory structure is recursed by setting: + $File::Copy::Recursive::MaxDepth +to a whole number greater than 0. + +=head2 SymLinks + +If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file. +Perl's symlink() is used instead of File::Copy's copy(). +You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value. +It is already set to true or false depending on your system's support of symlinks so you can check it with an if statement to see how it will behave: + + if($File::Copy::Recursive::CopyLink) { + print "Symlinks will be preserved\n"; + } else { + print "Symlinks will not be preserved because your system does not support it\n"; + } + +If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. It's false by default. + + local $File::Copy::Recursive::BdTrgWrn = 1; + +=head2 Removing existing target file or directory before copying. + +This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively. + +0 = off (This is the default) + +1 = carp() $! if removal fails + +2 = return if removal fails + + local $File::Copy::Recursive::RMTrgFil = 1; + fcopy($orig, $target) or die $!; + # if it fails it does warn() and keeps going + + local $File::Copy::Recursive::RMTrgDir = 2; + dircopy($orig, $target) or die $!; + # if it fails it does your "or die" + +This should be unnecessary most of the time but it's there if you need it :) + +=head2 Turning off stat() check + +By default the files or directories are checked to see if they are the same (i.e. linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info. +It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System") + +=head2 Emulating cp -rf dir1/ dir2/ + +By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not. + +You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true. + +NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists. +If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above. + +That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf. +If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf). + +So assuming 'foo/file': + + dircopy('foo', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + + $File::Copy::Recursive::CPRFComp = 1; + dircopy('foo', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/foo/file + +You can also specify a star for cp -rf glob type behavior: + + dircopy('foo/*', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + + $File::Copy::Recursive::CPRFComp = 1; + dircopy('foo/*', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + +NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (i.e. not like cp -rf fo* to copy foo/*). + +=head2 Allowing Copy Loops + +If you want to allow: + + cp -rf . foo/ + +type behavior set $File::Copy::Recursive::CopyLoop to true. + +This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem. + +If you ever find a situation where $CopyLoop = 1 is desirable let me know. (i.e. it's a bad bad idea but is there if you want it) + +(Note: On Windows this was necessary since it uses stat() to determine sameness and stat() is essentially useless for this on Windows. +The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share) + +=head1 SEE ALSO + +L L + +=head1 TO DO + +I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests. + +Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive. + +The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface. + +I'll add this after the latest version has been out for a while with no new features or issues found :) + +=head1 AUTHOR + +Daniel Muey, L + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Muey + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut Index: synthetic_sim/perl_lib/File/Find/Rule/Extending.pod =================================================================== --- synthetic_sim/perl_lib/File/Find/Rule/Extending.pod (nonexistent) +++ synthetic_sim/perl_lib/File/Find/Rule/Extending.pod (revision 56) @@ -0,0 +1,91 @@ +=head1 NAME + +File::Find::Rule::Extending - the mini-guide to extending File::Find::Rule + +=head1 SYNOPSIS + + package File::Find::Rule::Random; + use strict; + + # take useful things from File::Find::Rule + use base 'File::Find::Rule'; + + # and force our crack into the main namespace + sub File::Find::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + 1; + +=head1 DESCRIPTION + +File::Find::Rule went down so well with the buying public that +everyone wanted to add extra features. With the 0.07 release this +became a possibility, using the following conventions. + +=head2 Declare your package + + package File::Find::Rule::Random; + use strict; + +=head2 Inherit methods from File::Find::Rule + + # take useful things from File::Find::Rule + use base 'File::Find::Rule'; + +=head3 Force your madness into the main package + + # and force our crack into the main namespace + sub File::Find::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + +Yes, we're being very cavalier here and defining things into the main +File::Find::Rule namespace. This is due to lack of imaginiation on my +part - I simply can't find a way for the functional and oo interface +to work without doing this or some kind of inheritance, and +inheritance stops you using two File::Find::Rule::Foo modules +together. + +For this reason try and pick distinct names for your extensions. If +this becomes a problem then I may institute a semi-official registry +of taken names. + +=head2 Taking no arguments. + +Note the null prototype on random. This is a cheat for the procedural +interface to know that your sub takes no arguments, and so allows this +to happen: + + find( random => in => '.' ); + +If you hadn't declared C with a null prototype it would have +consumed C as a parameter to it, then got all confused as it +doesn't know about a C<'.'> rule. + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +L was the first extension module, so maybe +check that out. + +=cut + + + + Index: synthetic_sim/perl_lib/File/Find/Rule/Procedural.pod =================================================================== --- synthetic_sim/perl_lib/File/Find/Rule/Procedural.pod (nonexistent) +++ synthetic_sim/perl_lib/File/Find/Rule/Procedural.pod (revision 56) @@ -0,0 +1,72 @@ +=head1 NAME + +File::Find::Rule::Procedural - File::Find::Rule's procedural interface + +=head1 SYNOPSIS + + use File::Find::Rule; + + # find all .pm files, procedurally + my @files = find(file => name => '*.pm', in => \@INC); + +=head1 DESCRIPTION + +In addition to the regular object-oriented interface, +L provides two subroutines for you to use. + +=over + +=item C + +=item C + +C and C can be used to invoke any methods available to the +OO version. C is a synonym for C + +=back + +Passing more than one value to a clause is done with an anonymous +array: + + my $finder = find( name => [ '*.mp3', '*.ogg' ] ); + +C and C both return a File::Find::Rule instance, unless +one of the arguments is C, in which case it returns a list of +things that match the rule. + + my @files = find( name => [ '*.mp3', '*.ogg' ], in => $ENV{HOME} ); + +Please note that C will be the last clause evaluated, and so this +code will search for mp3s regardless of size. + + my @files = find( name => '*.mp3', in => $ENV{HOME}, size => '<2k' ); + ^ + | + Clause processing stopped here ------/ + +It is also possible to invert a single rule by prefixing it with C +like so: + + # large files that aren't videos + my @files = find( file => + '!name' => [ '*.avi', '*.mov' ], + size => '>20M', + in => $ENV{HOME} ); + + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2003 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut Index: synthetic_sim/perl_lib/File/Find/Rule.pm =================================================================== --- synthetic_sim/perl_lib/File/Find/Rule.pm (nonexistent) +++ synthetic_sim/perl_lib/File/Find/Rule.pm (revision 56) @@ -0,0 +1,817 @@ +# $Id$ + +package File::Find::Rule; +use strict; +use File::Spec; +use Text::Glob 'glob_to_regex'; +use Number::Compare; +use Carp qw/croak/; +use File::Find (); # we're only wrapping for now + +our $VERSION = '0.34'; + +# we'd just inherit from Exporter, but I want the colon +sub import { + my $pkg = shift; + my $to = caller; + for my $sym ( qw( find rule ) ) { + no strict 'refs'; + *{"$to\::$sym"} = \&{$sym}; + } + for (grep /^:/, @_) { + my ($extension) = /^:(.*)/; + eval "require File::Find::Rule::$extension"; + croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@; + } +} + +=head1 NAME + +File::Find::Rule - Alternative interface to File::Find + +=head1 SYNOPSIS + + use File::Find::Rule; + # find all the subdirectories of a given directory + my @subdirs = File::Find::Rule->directory->in( $directory ); + + # find all the .pm files in @INC + my @files = File::Find::Rule->file() + ->name( '*.pm' ) + ->in( @INC ); + + # as above, but without method chaining + my $rule = File::Find::Rule->new; + $rule->file; + $rule->name( '*.pm' ); + my @files = $rule->in( @INC ); + +=head1 DESCRIPTION + +File::Find::Rule is a friendlier interface to File::Find. It allows +you to build rules which specify the desired files and directories. + +=cut + +# the procedural shim + +*rule = \&find; +sub find { + my $object = __PACKAGE__->new(); + my $not = 0; + + while (@_) { + my $method = shift; + my @args; + + if ($method =~ s/^\!//) { + # jinkies, we're really negating this + unshift @_, $method; + $not = 1; + next; + } + unless (defined prototype $method) { + my $args = shift; + @args = ref $args eq 'ARRAY' ? @$args : $args; + } + if ($not) { + $not = 0; + @args = $object->new->$method(@args); + $method = "not"; + } + + my @return = $object->$method(@args); + return @return if $method eq 'in'; + } + $object; +} + + +=head1 METHODS + +=over + +=item C + +A constructor. You need not invoke C manually unless you wish +to, as each of the rule-making methods will auto-create a suitable +object if called as class methods. + +=cut + +sub new { + my $referent = shift; + my $class = ref $referent || $referent; + bless { + rules => [], + subs => {}, + iterator => [], + extras => {}, + maxdepth => undef, + mindepth => undef, + }, $class; +} + +sub _force_object { + my $object = shift; + $object = $object->new() + unless ref $object; + $object; +} + +=back + +=head2 Matching Rules + +=over + +=item C + +Specifies names that should match. May be globs or regular +expressions. + + $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs + $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex + $set->name( 'foo.bar' ); # just things named foo.bar + +=cut + +sub _flatten { + my @flat; + while (@_) { + my $item = shift; + ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; + } + return @flat; +} + +sub name { + my $self = _force_object shift; + my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); + + push @{ $self->{rules} }, { + rule => 'name', + code => join( ' || ', map { "m{$_}" } @names ), + args => \@_, + }; + + $self; +} + +=item -X tests + +Synonyms are provided for each of the -X tests. See L for +details. None of these methods take arguments. + + Test | Method Test | Method + ------|------------- ------|---------------- + -r | readable -R | r_readable + -w | writeable -W | r_writeable + -w | writable -W | r_writable + -x | executable -X | r_executable + -o | owned -O | r_owned + | | + -e | exists -f | file + -z | empty -d | directory + -s | nonempty -l | symlink + | -p | fifo + -u | setuid -S | socket + -g | setgid -b | block + -k | sticky -c | character + | -t | tty + -M | modified | + -A | accessed -T | ascii + -C | changed -B | binary + +Though some tests are fairly meaningless as binary flags (C, +C, C), they have been included for completeness. + + # find nonempty files + $rule->file, + ->nonempty; + +=cut + +use vars qw( %X_tests ); +%X_tests = ( + -r => readable => -R => r_readable => + -w => writeable => -W => r_writeable => + -w => writable => -W => r_writable => + -x => executable => -X => r_executable => + -o => owned => -O => r_owned => + + -e => exists => -f => file => + -z => empty => -d => directory => + -s => nonempty => -l => symlink => + => -p => fifo => + -u => setuid => -S => socket => + -g => setgid => -b => block => + -k => sticky => -c => character => + => -t => tty => + -M => modified => + -A => accessed => -T => ascii => + -C => changed => -B => binary => + ); + +for my $test (keys %X_tests) { + my $sub = eval 'sub () { + my $self = _force_object shift; + push @{ $self->{rules} }, { + code => "' . $test . ' \$_", + rule => "'.$X_tests{$test}.'", + }; + $self; + } '; + no strict 'refs'; + *{ $X_tests{$test} } = $sub; +} + + +=item stat tests + +The following C based methods are provided: C, C, +C, C, C, C, C, C, C, +C, C, C, and C. See L +for details. + +Each of these can take a number of targets, which will follow +L semantics. + + $rule->size( 7 ); # exactly 7 + $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes + $rule->size( ">=7" ) + ->size( "<=90" ); # between 7 and 90, inclusive + $rule->size( 7, 9, 42 ); # 7, 9 or 42 + +=cut + +use vars qw( @stat_tests ); +@stat_tests = qw( dev ino mode nlink uid gid rdev + size atime mtime ctime blksize blocks ); +{ + my $i = 0; + for my $test (@stat_tests) { + my $index = $i++; # to close over + my $sub = sub { + my $self = _force_object shift; + + my @tests = map { Number::Compare->parse_to_perl($_) } @_; + + push @{ $self->{rules} }, { + rule => $test, + args => \@_, + code => 'do { my $val = (stat $_)['.$index.'] || 0;'. + join ('||', map { "(\$val $_)" } @tests ).' }', + }; + $self; + }; + no strict 'refs'; + *$test = $sub; + } +} + +=item C + +=item C + +Allows shortcircuiting boolean evaluation as an alternative to the +default and-like nature of combined rules. C and C are +interchangeable. + + # find avis, movs, things over 200M and empty files + $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ), + File::Find::Rule->size( '>200M' ), + File::Find::Rule->file->empty, + ); + +=cut + +sub any { + my $self = _force_object shift; + # compile all the subrules to code fragments + push @{ $self->{rules} }, { + rule => "any", + code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')', + args => \@_, + }; + + # merge all the subs hashes of the kids into ourself + %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; + $self; +} + +*or = \&any; + +=item C + +=item C + +Negates a rule. (The inverse of C.) C and C are +interchangeable. + + # files that aren't 8.3 safe + $rule->file + ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); + +=cut + +sub not { + my $self = _force_object shift; + + push @{ $self->{rules} }, { + rule => 'not', + args => \@_, + code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")", + }; + + # merge all the subs hashes into us + %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; + $self; +} + +*none = \¬ + +=item C + +Traverse no further. This rule always matches. + +=cut + +sub prune () { + my $self = _force_object shift; + + push @{ $self->{rules} }, + { + rule => 'prune', + code => '$File::Find::prune = 1' + }; + $self; +} + +=item C + +Don't keep this file. This rule always matches. + +=cut + +sub discard () { + my $self = _force_object shift; + + push @{ $self->{rules} }, { + rule => 'discard', + code => '$discarded = 1', + }; + $self; +} + +=item C + +Allows user-defined rules. Your subroutine will be invoked with C<$_> +set to the current short name, and with parameters of the name, the +path you're in, and the full relative filename. + +Return a true value if your rule matched. + + # get things with long names + $rules->exec( sub { length > 20 } ); + +=cut + +sub exec { + my $self = _force_object shift; + my $code = shift; + + push @{ $self->{rules} }, { + rule => 'exec', + code => $code, + }; + $self; +} + +=item C + +Opens a file and tests it each line at a time. + +For each line it evaluates each of the specifiers, stopping at the +first successful match. A specifier may be a regular expression or a +subroutine. The subroutine will be invoked with the same parameters +as an ->exec subroutine. + +It is possible to provide a set of negative specifiers by enclosing +them in anonymous arrays. Should a negative specifier match the +iteration is aborted and the clause is failed. For example: + + $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); + +Is a passing clause if the first line of a file looks like a perl +shebang line. + +=cut + +sub grep { + my $self = _force_object shift; + my @pattern = map { + ref $_ + ? ref $_ eq 'ARRAY' + ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ + : [ $_ => 1 ] + : [ qr/$_/ => 1 ] + } @_; + + $self->exec( sub { + local *FILE; + open FILE, $_ or return; + local ($_, $.); + while () { + for my $p (@pattern) { + my ($rule, $ret) = @$p; + return $ret + if ref $rule eq 'Regexp' + ? /$rule/ + : $rule->(@_); + } + } + return; + } ); +} + +=item C + +Descend at most C<$level> (a non-negative integer) levels of directories +below the starting point. + +May be invoked many times per rule, but only the most recent value is +used. + +=item C + +Do not apply any tests at levels less than C<$level> (a non-negative +integer). + +=item C + +Specifies extra values to pass through to C as part +of the options hash. + +For example this allows you to specify following of symlinks like so: + + my $rule = File::Find::Rule->extras({ follow => 1 }); + +May be invoked many times per rule, but only the most recent value is +used. + +=cut + +for my $setter (qw( maxdepth mindepth extras )) { + my $sub = sub { + my $self = _force_object shift; + $self->{$setter} = shift; + $self; + }; + no strict 'refs'; + *$setter = $sub; +} + + +=item C + +Trim the leading portion of any path found + +=cut + +sub relative () { + my $self = _force_object shift; + $self->{relative} = 1; + $self; +} + +=item C + +Normalize paths found using Ccanonpath>. This will return paths +with a file-seperator that is native to your OS (as determined by L), + instead of the default C. + +For example, this will return C on Unix-ish OSes +and C on Win32. + +=cut + +sub canonpath () { + my $self = _force_object shift; + $self->{canonpath} = 1; + $self; +} + +=item C + +Negated version of the rule. An effective shortand related to ! in +the procedural interface. + + $foo->not_name('*.pl'); + + $foo->not( $foo->new->name('*.pl' ) ); + +=cut + +sub DESTROY {} +sub AUTOLOAD { + our $AUTOLOAD; + $AUTOLOAD =~ /::not_([^:]*)$/ + or croak "Can't locate method $AUTOLOAD"; + my $method = $1; + + my $sub = sub { + my $self = _force_object shift; + $self->not( $self->new->$method(@_) ); + }; + { + no strict 'refs'; + *$AUTOLOAD = $sub; + } + &$sub; +} + +=back + +=head2 Query Methods + +=over + +=item C + +Evaluates the rule, returns a list of paths to matching files and +directories. + +=cut + +sub in { + my $self = _force_object shift; + + my @found; + my $fragment = $self->_compile; + my %subs = %{ $self->{subs} }; + + warn "relative mode handed multiple paths - that's a bit silly\n" + if $self->{relative} && @_ > 1; + + my $topdir; + my $code = 'sub { + (my $path = $File::Find::name) =~ s#^(?:\./+)+##; + my @args = ($_, $File::Find::dir, $path); + my $maxdepth = $self->{maxdepth}; + my $mindepth = $self->{mindepth}; + my $relative = $self->{relative}; + my $canonpath = $self->{canonpath}; + + # figure out the relative path and depth + my $relpath = $File::Find::name; + $relpath =~ s{^\Q$topdir\E/?}{}; + my $depth = scalar File::Spec->splitdir($relpath); + #print "name: \'$File::Find::name\' "; + #print "relpath: \'$relpath\' depth: $depth relative: $relative\n"; + + defined $maxdepth && $depth >= $maxdepth + and $File::Find::prune = 1; + + defined $mindepth && $depth < $mindepth + and return; + + #print "Testing \'$_\'\n"; + + my $discarded; + return unless ' . $fragment . '; + return if $discarded; + if ($relative) { + if ($relpath ne "") { + push @found, $canonpath ? File::Spec->canonpath($relpath) : $relpath; + } + } + else { + push @found, $canonpath ? File::Spec->canonpath($path) : $path; + } + }'; + + #use Data::Dumper; + #print Dumper \%subs; + #warn "Compiled sub: '$code'\n"; + + my $sub = eval "$code" or die "compile error '$code' $@"; + for my $path (@_) { + # $topdir is used for relative and maxdepth + $topdir = $path; + # slice off the trailing slash if there is one (the + # maxdepth/mindepth code is fussy) + $topdir =~ s{/?$}{} + unless $topdir eq '/'; + $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path ); + } + + return @found; +} + +sub _call_find { + my $self = shift; + File::Find::find( @_ ); +} + +sub _compile { + my $self = shift; + + return '1' unless @{ $self->{rules} }; + my $code = join " && ", map { + if (ref $_->{code}) { + my $key = "$_->{code}"; + $self->{subs}{$key} = $_->{code}; + "\$subs{'$key'}->(\@args) # $_->{rule}\n"; + } + else { + "( $_->{code} ) # $_->{rule}\n"; + } + } @{ $self->{rules} }; + + #warn $code; + return $code; +} + +=item C + +Starts a find across the specified directories. Matching items may +then be queried using L. This allows you to use a rule as an +iterator. + + my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" ); + while ( defined ( my $image = $rule->match ) ) { + ... + } + +=cut + +sub start { + my $self = _force_object shift; + + $self->{iterator} = [ $self->in( @_ ) ]; + $self; +} + +=item C + +Returns the next file which matches, false if there are no more. + +=cut + +sub match { + my $self = _force_object shift; + + return shift @{ $self->{iterator} }; +} + +1; + +__END__ + +=back + +=head2 Extensions + +Extension modules are available from CPAN in the File::Find::Rule +namespace. In order to use these extensions either use them directly: + + use File::Find::Rule::ImageSize; + use File::Find::Rule::MMagic; + + # now your rules can use the clauses supplied by the ImageSize and + # MMagic extension + +or, specify that File::Find::Rule should load them for you: + + use File::Find::Rule qw( :ImageSize :MMagic ); + +For notes on implementing your own extensions, consult +L + +=head2 Further examples + +=over + +=item Finding perl scripts + + my $finder = File::Find::Rule->or + ( + File::Find::Rule->name( '*.pl' ), + File::Find::Rule->exec( + sub { + if (open my $fh, $_) { + my $shebang = <$fh>; + close $fh; + return $shebang =~ /^#!.*\bperl/; + } + return 0; + } ), + ); + +Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 + +=item ignore CVS directories + + my $rule = File::Find::Rule->new; + $rule->or($rule->new + ->directory + ->name('CVS') + ->prune + ->discard, + $rule->new); + +Note here the use of a null rule. Null rules match anything they see, +so the effect is to match (and discard) directories called 'CVS' or to +match anything. + +=back + +=head1 TWO FOR THE PRICE OF ONE + +File::Find::Rule also gives you a procedural interface. This is +documented in L + +=head1 EXPORTS + +L, L + +=head1 TAINT MODE INTERACTION + +As of 0.32 File::Find::Rule doesn't capture the current working directory in +a taint-unsafe manner. File::Find itself still does operations that the taint +system will flag as insecure but you can use the L feature to ask +L to internally C file paths with a regex like so: + + my $rule = File::Find::Rule->extras({ untaint => 1 }); + +Please consult L's documentation for C, +C, and C for more information. + +=head1 BUGS + +The code makes use of the C keyword and as such requires perl version +5.6.0 or newer. + +Currently it isn't possible to remove a clause from a rule object. If +this becomes a significant issue it will be addressed. + +=head1 AUTHOR + +Richard Clamp with input gained from this +use.perl discussion: http://use.perl.org/~richardc/journal/6467 + +Additional proofreading and input provided by Kake, Greg McCarroll, +and Andy Lester andy@petdance.com. + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2004, 2006, 2009, 2011 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L, L, find(1) + +If you want to know about the procedural interface, see +L, and if you have an idea for a neat +extension L + +=cut + +Implementation notes: + +$self->rules is an array of hashrefs. it may be a code fragment or a call +to a subroutine. + +Anonymous subroutines are stored in the $self->subs hashref keyed on the +stringfied version of the coderef. + +When one File::Find::Rule object is combined with another, such as in the any +and not operations, this entire hash is merged. + +The _compile method walks the rules element and simply glues the code +fragments together so they can be compiled into an anyonymous File::Find +match sub for speed + + +[*] There's probably a win to be made with the current model in making +stat calls use C<_>. For + + find( file => size => "> 20M" => size => "< 400M" ); + +up to 3 stats will happen for each candidate. Adding a priming _ +would be a bit blind if the first operation was C< name => 'foo' >, +since that can be tested by a single regex. Simply checking what the +next type of operation doesn't work since any arbritary exec sub may +or may not stat. Potentially worse, they could stat something else +like so: + + # extract from the worlds stupidest make(1) + find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } ); + +Maybe the best way is to treat C<_> as invalid after calling an exec, +and doc that C<_> will only be meaningful after stat and -X tests if +they're wanted in exec blocks. Index: synthetic_sim/perl_lib/List/MoreUtils/PP.pm =================================================================== --- synthetic_sim/perl_lib/List/MoreUtils/PP.pm (nonexistent) +++ synthetic_sim/perl_lib/List/MoreUtils/PP.pm (revision 56) @@ -0,0 +1,953 @@ +package List::MoreUtils::PP; + +use 5.008_001; +use strict; +use warnings; + +our $VERSION = '0.430'; + +=pod + +=head1 NAME + +List::MoreUtils::PP - Provide List::MoreUtils pure Perl implementation + +=head1 SYNOPSIS + + BEGIN { $ENV{LIST_MOREUTILS_PP} = 1; } + use List::MoreUtils qw(:all); + +=cut + +## no critic (Subroutines::ProhibitSubroutinePrototypes, Subroutines::RequireArgUnpacking) +## no critic (Subroutines::ProhibitManyArgs) + +sub any (&@) +{ + my $f = shift; + foreach (@_) + { + return 1 if $f->(); + } + return 0; +} + +sub all (&@) +{ + my $f = shift; + foreach (@_) + { + return 0 unless $f->(); + } + return 1; +} + +sub none (&@) +{ + my $f = shift; + foreach (@_) + { + return 0 if $f->(); + } + return 1; +} + +sub notall (&@) +{ + my $f = shift; + foreach (@_) + { + return 1 unless $f->(); + } + return 0; +} + +sub one (&@) +{ + my $f = shift; + my $found = 0; + foreach (@_) + { + $f->() and $found++ and return 0; + } + return $found; +} + +sub any_u (&@) +{ + my $f = shift; + return if !@_; + $f->() and return 1 foreach (@_); + return 0; +} + +sub all_u (&@) +{ + my $f = shift; + return if !@_; + $f->() or return 0 foreach (@_); + return 1; +} + +sub none_u (&@) +{ + my $f = shift; + return if !@_; + $f->() and return 0 foreach (@_); + return 1; +} + +sub notall_u (&@) +{ + my $f = shift; + return if !@_; + $f->() or return 1 foreach (@_); + return 0; +} + +sub one_u (&@) +{ + my $f = shift; + return if !@_; + my $found = 0; + foreach (@_) + { + $f->() and $found++ and return 0; + } + return $found; +} + +sub reduce_u(&@) +{ + my $code = shift; + + # Localise $a, $b + my ($caller_a, $caller_b) = do + { + my $pkg = caller(); + ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) + no strict 'refs'; + \*{$pkg . '::a'}, \*{$pkg . '::b'}; + }; + + ## no critic (Variables::RequireInitializationForLocalVars) + local (*$caller_a, *$caller_b); + *$caller_a = \(); + for (0 .. $#_) + { + *$caller_b = \$_[$_]; + *$caller_a = \($code->()); + } + + return ${*$caller_a}; +} + +sub reduce_0(&@) +{ + my $code = shift; + + # Localise $a, $b + my ($caller_a, $caller_b) = do + { + my $pkg = caller(); + ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) + no strict 'refs'; + \*{$pkg . '::a'}, \*{$pkg . '::b'}; + }; + + ## no critic (Variables::RequireInitializationForLocalVars) + local (*$caller_a, *$caller_b); + *$caller_a = \0; + for (0 .. $#_) + { + *$caller_b = \$_[$_]; + *$caller_a = \($code->()); + } + + return ${*$caller_a}; +} + +sub reduce_1(&@) +{ + my $code = shift; + + # Localise $a, $b + my ($caller_a, $caller_b) = do + { + my $pkg = caller(); + ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) + no strict 'refs'; + \*{$pkg . '::a'}, \*{$pkg . '::b'}; + }; + + ## no critic (Variables::RequireInitializationForLocalVars) + local (*$caller_a, *$caller_b); + *$caller_a = \1; + for (0 .. $#_) + { + *$caller_b = \$_[$_]; + *$caller_a = \($code->()); + } + + return ${*$caller_a}; +} + +sub true (&@) +{ + my $f = shift; + my $count = 0; + $f->() and ++$count foreach (@_); + return $count; +} + +sub false (&@) +{ + my $f = shift; + my $count = 0; + $f->() or ++$count foreach (@_); + return $count; +} + +sub firstidx (&@) +{ + my $f = shift; + foreach my $i (0 .. $#_) + { + local *_ = \$_[$i]; + return $i if $f->(); + } + return -1; +} + +sub firstval (&@) +{ + my $test = shift; + foreach (@_) + { + return $_ if $test->(); + } + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef; +} + +sub firstres (&@) +{ + my $test = shift; + foreach (@_) + { + my $testval = $test->(); + $testval and return $testval; + } + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef; +} + +sub onlyidx (&@) +{ + my $f = shift; + my $found; + foreach my $i (0 .. $#_) + { + local *_ = \$_[$i]; + $f->() or next; + defined $found and return -1; + $found = $i; + } + return defined $found ? $found : -1; +} + +sub onlyval (&@) +{ + my $test = shift; + my $result = undef; + my $found = 0; + foreach (@_) + { + $test->() or next; + $result = $_; + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + $found++ and return undef; + } + return $result; +} + +sub onlyres (&@) +{ + my $test = shift; + my $result = undef; + my $found = 0; + foreach (@_) + { + my $rv = $test->() or next; + $result = $rv; + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + $found++ and return undef; + } + return $found ? $result : undef; +} + +sub lastidx (&@) +{ + my $f = shift; + foreach my $i (reverse 0 .. $#_) + { + local *_ = \$_[$i]; + return $i if $f->(); + } + return -1; +} + +sub lastval (&@) +{ + my $test = shift; + my $ix; + for ($ix = $#_; $ix >= 0; $ix--) + { + local *_ = \$_[$ix]; + my $testval = $test->(); + + # Simulate $_ as alias + $_[$ix] = $_; + return $_ if $testval; + } + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef; +} + +sub lastres (&@) +{ + my $test = shift; + my $ix; + for ($ix = $#_; $ix >= 0; $ix--) + { + local *_ = \$_[$ix]; + my $testval = $test->(); + + # Simulate $_ as alias + $_[$ix] = $_; + return $testval if $testval; + } + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef; +} + +sub insert_after (&$\@) +{ + my ($f, $val, $list) = @_; + my $c = &firstidx($f, @$list); + @$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1; + return 0; +} + +sub insert_after_string ($$\@) +{ + my ($string, $val, $list) = @_; + my $c = firstidx { defined $_ and $string eq $_ } @$list; + @$list = (@{$list}[0 .. $c], $val, @{$list}[$c + 1 .. $#$list],) and return 1 if $c != -1; + return 0; +} + +sub apply (&@) +{ + my $action = shift; + &$action foreach my @values = @_; + return wantarray ? @values : $values[-1]; +} + +sub after (&@) +{ + my $test = shift; + my $started; + my $lag; + ## no critic (BuiltinFunctions::RequireBlockGrep) + return grep $started ||= do + { + my $x = $lag; + $lag = $test->(); + $x; + }, @_; +} + +sub after_incl (&@) +{ + my $test = shift; + my $started; + return grep { $started ||= $test->() } @_; +} + +sub before (&@) +{ + my $test = shift; + my $more = 1; + return grep { $more &&= !$test->() } @_; +} + +sub before_incl (&@) +{ + my $test = shift; + my $more = 1; + my $lag = 1; + ## no critic (BuiltinFunctions::RequireBlockGrep) + return grep $more &&= do + { + my $x = $lag; + $lag = !$test->(); + $x; + }, @_; +} + +sub indexes (&@) +{ + my $test = shift; + return grep { + local *_ = \$_[$_]; + $test->() + } 0 .. $#_; +} + +sub pairwise (&\@\@) +{ + my $op = shift; + + # Symbols for caller's input arrays + use vars qw{ @A @B }; + local (*A, *B) = @_; + + # Localise $a, $b + my ($caller_a, $caller_b) = do + { + my $pkg = caller(); + ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) + no strict 'refs'; + \*{$pkg . '::a'}, \*{$pkg . '::b'}; + }; + + # Loop iteration limit + my $limit = $#A > $#B ? $#A : $#B; + + ## no critic (Variables::RequireInitializationForLocalVars) + # This map expression is also the return value + local (*$caller_a, *$caller_b); + ## no critic (BuiltinFunctions::ProhibitComplexMappings) + return map { + # Assign to $a, $b as refs to caller's array elements + (*$caller_a, *$caller_b) = \($#A < $_ ? undef : $A[$_], $#B < $_ ? undef : $B[$_]); + + # Perform the transformation + $op->(); + } 0 .. $limit; +} + +sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) +{ + return each_arrayref(@_); +} + +sub each_arrayref +{ + my @list = @_; # The list of references to the arrays + my $index = 0; # Which one the caller will get next + my $max = 0; # Number of elements in longest array + + # Get the length of the longest input array + foreach (@list) + { + unless (ref $_ eq 'ARRAY') + { + require Carp; + Carp::croak("each_arrayref: argument is not an array reference\n"); + } + $max = @$_ if @$_ > $max; + } + + # Return the iterator as a closure wrt the above variables. + return sub { + if (@_) + { + my $method = shift; + unless ($method eq 'index') + { + require Carp; + Carp::croak("each_array: unknown argument '$method' passed to iterator."); + } + + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef if $index == 0 || $index > $max; + # Return current (last fetched) index + return $index - 1; + } + + # No more elements to return + return if $index >= $max; + my $i = $index++; + + # Return ith elements + ## no critic (BuiltinFunctions::RequireBlockMap) + return map $_->[$i], @list; + } +} + +sub natatime ($@) +{ + my $n = shift; + my @list = @_; + return sub { return splice @list, 0, $n; } +} + +# "leaks" when lexically hidden in arrayify +my $flatten; +$flatten = sub { + return map { (ref $_ and ("ARRAY" eq ref $_ or overload::Method($_, '@{}'))) ? ($flatten->(@{$_})) : ($_) } @_; +}; + +sub arrayify +{ + return map { $flatten->($_) } @_; +} + +sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) +{ + my $max = -1; + $max < $#$_ && ($max = $#$_) foreach @_; + ## no critic (BuiltinFunctions::ProhibitComplexMappings) + return map { + my $ix = $_; + ## no critic (BuiltinFunctions::RequireBlockMap) + map $_->[$ix], @_; + } 0 .. $max; +} + +sub zip6 (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) +{ + my $max = -1; + $max < $#$_ && ($max = $#$_) foreach @_; + ## no critic (BuiltinFunctions::ProhibitComplexMappings) + return map { + my $ix = $_; + ## no critic (BuiltinFunctions::RequireBlockMap) + [map $_->[$ix], @_]; + } 0 .. $max; +} + +sub listcmp (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) +{ + my %ret; + for (my $i = 0; $i < scalar @_; ++$i) + { + my %seen; + my $k; + foreach my $w (grep { defined $_ and not $seen{$k = $_}++ } @{$_[$i]}) + { + $ret{$w} ||= []; + push @{$ret{$w}}, $i; + } + } + return %ret; +} + +sub uniq (@) +{ + my %seen = (); + my $k; + my $seen_undef; + return grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; +} + +sub singleton (@) +{ + my %seen = (); + my $k; + my $seen_undef; + return grep { 1 == (defined $_ ? $seen{$k = $_} : $seen_undef) } + grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; +} + +sub duplicates (@) +{ + my %seen = (); + my $k; + my $seen_undef; + return grep { 1 < (defined $_ ? $seen{$k = $_} : $seen_undef) } + grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; +} + +sub frequency (@) +{ + my %seen = (); + my $k; + my $seen_undef; + my %h = map { defined $_ ? ($_ => $seen{$k = $_}) : () } + grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_; + wantarray or return (scalar keys %h) + ($seen_undef ? 1 : 0); + undef $k; + return (%h, $seen_undef ? (\$k => $seen_undef) : ()); +} + +sub occurrences (@) +{ + my %seen = (); + my $k; + my $seen_undef; + my @ret; + foreach my $l (map { $_ } grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_) + { + my $n = defined $l ? $seen{$l} : $seen_undef; + defined $ret[$n] or $ret[$n] = []; + push @{$ret[$n]}, $l; + } + return @ret; +} + +sub mode (@) +{ + my %seen = (); + my ($max, $k, $seen_undef) = (1); + + foreach (@_) { defined $_ ? ($max < ++$seen{$k = $_} and ++$max) : ($max < ++$seen_undef and ++$max) } + wantarray or return $max; + + my @ret = ($max); + foreach my $l (grep { $seen{$_} == $max } keys %seen) + { + push @ret, $l; + } + $seen_undef and $seen_undef == $max and push @ret, undef; + return @ret; +} + +sub samples ($@) +{ + my $n = shift; + if ($n > @_) + { + require Carp; + Carp::croak(sprintf("Cannot get %d samples from %d elements", $n, scalar @_)); + } + + for (my $i = @_; @_ - $i > $n;) + { + my $idx = @_ - $i; + my $swp = $idx + int(rand(--$i)); + my $xchg = $_[$swp]; + $_[$swp] = $_[$idx]; + $_[$idx] = $xchg; + } + + return splice @_, 0, $n; +} + +sub minmax (@) +{ + return unless @_; + my $min = my $max = $_[0]; + + for (my $i = 1; $i < @_; $i += 2) + { + if ($_[$i - 1] <= $_[$i]) + { + $min = $_[$i - 1] if $min > $_[$i - 1]; + $max = $_[$i] if $max < $_[$i]; + } + else + { + $min = $_[$i] if $min > $_[$i]; + $max = $_[$i - 1] if $max < $_[$i - 1]; + } + } + + if (@_ & 1) + { + my $i = $#_; + if ($_[$i - 1] <= $_[$i]) + { + $min = $_[$i - 1] if $min > $_[$i - 1]; + $max = $_[$i] if $max < $_[$i]; + } + else + { + $min = $_[$i] if $min > $_[$i]; + $max = $_[$i - 1] if $max < $_[$i - 1]; + } + } + + return ($min, $max); +} + +sub minmaxstr (@) +{ + return unless @_; + my $min = my $max = $_[0]; + + for (my $i = 1; $i < @_; $i += 2) + { + if ($_[$i - 1] le $_[$i]) + { + $min = $_[$i - 1] if $min gt $_[$i - 1]; + $max = $_[$i] if $max lt $_[$i]; + } + else + { + $min = $_[$i] if $min gt $_[$i]; + $max = $_[$i - 1] if $max lt $_[$i - 1]; + } + } + + if (@_ & 1) + { + my $i = $#_; + if ($_[$i - 1] le $_[$i]) + { + $min = $_[$i - 1] if $min gt $_[$i - 1]; + $max = $_[$i] if $max lt $_[$i]; + } + else + { + $min = $_[$i] if $min gt $_[$i]; + $max = $_[$i - 1] if $max lt $_[$i - 1]; + } + } + + return ($min, $max); +} + +sub part (&@) +{ + my ($code, @list) = @_; + my @parts; + push @{$parts[$code->($_)]}, $_ foreach @list; + return @parts; +} + +sub bsearch(&@) +{ + my $code = shift; + + my $rc; + my $i = 0; + my $j = @_; + ## no critic (ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions) + do + { + my $k = int(($i + $j) / 2); + + $k >= @_ and return; + + local *_ = \$_[$k]; + $rc = $code->(); + + $rc == 0 + and return wantarray ? $_ : 1; + + if ($rc < 0) + { + $i = $k + 1; + } + else + { + $j = $k - 1; + } + } until $i > $j; + + return; +} + +sub bsearchidx(&@) +{ + my $code = shift; + + my $rc; + my $i = 0; + my $j = @_; + ## no critic (ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions) + do + { + my $k = int(($i + $j) / 2); + + $k >= @_ and return -1; + + local *_ = \$_[$k]; + $rc = $code->(); + + $rc == 0 and return $k; + + if ($rc < 0) + { + $i = $k + 1; + } + else + { + $j = $k - 1; + } + } until $i > $j; + + return -1; +} + +sub lower_bound(&@) +{ + my $code = shift; + my $count = @_; + my $first = 0; + while ($count > 0) + { + my $step = $count >> 1; + my $it = $first + $step; + local *_ = \$_[$it]; + if ($code->() < 0) + { + $first = ++$it; + $count -= $step + 1; + } + else + { + $count = $step; + } + } + + return $first; +} + +sub upper_bound(&@) +{ + my $code = shift; + my $count = @_; + my $first = 0; + while ($count > 0) + { + my $step = $count >> 1; + my $it = $first + $step; + local *_ = \$_[$it]; + if ($code->() <= 0) + { + $first = ++$it; + $count -= $step + 1; + } + else + { + $count = $step; + } + } + + return $first; +} + +sub equal_range(&@) +{ + my $lb = &lower_bound(@_); + my $ub = &upper_bound(@_); + return ($lb, $ub); +} + +sub binsert (&$\@) +{ + my $lb = &lower_bound($_[0], @{$_[2]}); + splice @{$_[2]}, $lb, 0, $_[1]; + return $lb; +} + +sub bremove (&\@) +{ + my $lb = &lower_bound($_[0], @{$_[1]}); + return splice @{$_[1]}, $lb, 1; +} + +sub qsort(&\@) +{ + require Carp; + Carp::croak("It's insane to use a pure-perl qsort"); +} + +sub slide(&@) +{ + my $op = shift; + my @l = @_; + + ## no critic (TestingAndDebugging::ProhibitNoStrict, ValuesAndExpressions::ProhibitCommaSeparatedStatements) + # Localise $a, $b + my ($caller_a, $caller_b) = do + { + my $pkg = caller(); + no strict 'refs'; + \*{$pkg . '::a'}, \*{$pkg . '::b'}; + }; + + ## no critic (Variables::RequireInitializationForLocalVars) + # This map expression is also the return value + local (*$caller_a, *$caller_b); + ## no critic (BuiltinFunctions::ProhibitComplexMappings) + return map { + # Assign to $a, $b as refs to caller's array elements + (*$caller_a, *$caller_b) = \($l[$_], $l[$_ + 1]); + + # Perform the transformation + $op->(); + } 0 .. ($#l - 1); +} + +sub slideatatime ($$@) +{ + my ($m, $w, @list) = @_; + my $n = $w - $m - 1; + return $n >= 0 + ? sub { my @r = splice @list, 0, $m; $#list < $n and $n = $#list; @r and push @r, (@list ? @list[0 .. $n] : ()); return @r; } + : sub { return splice @list, 0, $m; }; +} + +sub sort_by(&@) +{ + my ($code, @list) = @_; + return map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [$_, scalar($code->())] } @list; +} + +sub nsort_by(&@) +{ + my ($code, @list) = @_; + return map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [$_, scalar($code->())] } @list; +} + +## no critic (Subroutines::ProhibitUnusedPrivateSubroutines) +sub _XScompiled { return 0 } + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Jens Rehsack Erehsack AT cpan.orgE + +Adam Kennedy Eadamk@cpan.orgE + +Tassilo von Parseval Etassilo.von.parseval@rwth-aachen.deE + +=head1 COPYRIGHT AND LICENSE + +Some parts copyright 2011 Aaron Crane. + +Copyright 2004 - 2010 by Tassilo von Parseval + +Copyright 2013 - 2017 by Jens Rehsack + +All code added with 0.417 or later is licensed under the Apache License, +Version 2.0 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +All code until 0.416 is licensed under the same terms as Perl itself, +either Perl version 5.8.4 or, at your option, any later version of +Perl 5 you may have available. + +=cut + +1; Index: synthetic_sim/perl_lib/List/MoreUtils.pm =================================================================== --- synthetic_sim/perl_lib/List/MoreUtils.pm (nonexistent) +++ synthetic_sim/perl_lib/List/MoreUtils.pm (revision 56) @@ -0,0 +1,1286 @@ +package List::MoreUtils; + +use 5.008_001; +use strict; +use warnings; + +my $have_xs; +our $VERSION = '0.430'; + +BEGIN +{ + unless (defined($have_xs)) + { + ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval) + eval { require List::MoreUtils::XS; } unless $ENV{LIST_MOREUTILS_PP}; + ## no critic (ErrorHandling::RequireCarping) + die $@ if $@ && defined $ENV{LIST_MOREUTILS_PP} && $ENV{LIST_MOREUTILS_PP} == 0; + $have_xs = 0 + defined($INC{'List/MoreUtils/XS.pm'}); + } + + use List::MoreUtils::PP qw(); +} + +use Exporter::Tiny qw(); + +my @junctions = qw(any all none notall); +my @v0_22 = qw( + true false + firstidx lastidx + insert_after insert_after_string + apply indexes + after after_incl before before_incl + firstval lastval + each_array each_arrayref + pairwise natatime + mesh uniq + minmax part + _XScompiled +); +my @v0_24 = qw(bsearch); +my @v0_33 = qw(sort_by nsort_by); +my @v0_400 = qw(one any_u all_u none_u notall_u one_u + firstres onlyidx onlyval onlyres lastres + singleton bsearchidx +); +my @v0_420 = qw(arrayify duplicates minmaxstr samples zip6 reduce_0 reduce_1 reduce_u + listcmp frequency occurrences mode + binsert bremove equal_range lower_bound upper_bound qsort + slide slideatatime); + +my @all_functions = (@junctions, @v0_22, @v0_24, @v0_33, @v0_400, @v0_420); + +## no critic (TestingAndDebugging::ProhibitNoStrict) +no strict "refs"; +if ($have_xs) +{ + my $x; + for (@all_functions) + { + List::MoreUtils->can($_) or *$_ = $x if ($x = List::MoreUtils::XS->can($_)); + } +} +List::MoreUtils->can($_) or *$_ = List::MoreUtils::PP->can($_) for (@all_functions); +use strict; +## use critic (TestingAndDebugging::ProhibitNoStrict) +use parent qw(Exporter::Tiny); + +my %alias_list = ( + v0_22 => { + first_index => "firstidx", + last_index => "lastidx", + first_value => "firstval", + last_value => "lastval", + zip => "mesh", + }, + v0_33 => { + distinct => "uniq", + }, + v0_400 => { + first_result => "firstres", + only_index => "onlyidx", + only_value => "onlyval", + only_result => "onlyres", + last_result => "lastres", + bsearch_index => "bsearchidx", + }, + v0_420 => { + bsearch_insert => "binsert", + bsearch_remove => "bremove", + zip_unflatten => "zip6", + }, +); + +our @EXPORT_OK = (@all_functions, map { keys %$_ } values %alias_list); +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, + 'like_0.22' => [ + any_u => {-as => 'any'}, + all_u => {-as => 'all'}, + none_u => {-as => 'none'}, + notall_u => {-as => 'notall'}, + @v0_22, + keys %{$alias_list{v0_22}}, + ], + 'like_0.24' => [ + any_u => {-as => 'any'}, + all_u => {-as => 'all'}, + notall_u => {-as => 'notall'}, + 'none', + @v0_22, + @v0_24, + keys %{$alias_list{v0_22}}, + ], + 'like_0.33' => [ + @junctions, + @v0_22, + # v0_24 functions were omitted + @v0_33, + keys %{$alias_list{v0_22}}, + keys %{$alias_list{v0_33}}, + ], +); + +for my $set (values %alias_list) +{ + for my $alias (keys %$set) + { + ## no critic (TestingAndDebugging::ProhibitNoStrict) + no strict qw(refs); + *$alias = __PACKAGE__->can($set->{$alias}); + ## use critic (TestingAndDebugging::ProhibitNoStrict) + } +} +use strict; + +=pod + +=head1 NAME + +List::MoreUtils - Provide the stuff missing in List::Util + +=head1 SYNOPSIS + + # import specific functions + + use List::MoreUtils qw(any uniq); + + if ( any { /foo/ } uniq @has_duplicates ) { + # do stuff + } + + # import everything + + use List::MoreUtils ':all'; + + # import by API + + # has "original" any/all/none/notall behavior + use List::MoreUtils ':like_0.22'; + # 0.22 + bsearch + use List::MoreUtils ':like_0.24'; + # has "simplified" any/all/none/notall behavior + (n)sort_by + use List::MoreUtils ':like_0.33'; + +=head1 DESCRIPTION + +B provides some trivial but commonly needed functionality on +lists which is not going to go into L. + +All of the below functions are implementable in only a couple of lines of Perl +code. Using the functions from this module however should give slightly better +performance as everything is implemented in C. The pure-Perl implementation of +these functions only serves as a fallback in case the C portions of this module +couldn't be compiled on this machine. + +=head1 EXPORTS + +=head2 Default behavior + +Nothing by default. To import all of this module's symbols use the C<:all> tag. +Otherwise functions can be imported by name as usual: + + use List::MoreUtils ':all'; + + use List::MoreUtils qw{ any firstidx }; + +Because historical changes to the API might make upgrading List::MoreUtils +difficult for some projects, the legacy API is available via special import +tags. + +=head2 Like version 0.22 (last release with original API) + +This API was available from 2006 to 2009, returning undef for empty lists on +C/C/C/C: + + use List::MoreUtils ':like_0.22'; + +This import tag will import all functions available as of version 0.22. +However, it will import C as C, C as C, C as +C, and C as C. + +=head2 Like version 0.24 (first incompatible change) + +This API was available from 2010 to 2011. It changed the return value of C +and added the C function. + + use List::MoreUtils ':like_0.24'; + +This import tag will import all functions available as of version 0.24. +However it will import C as C, C as C, and +C as C. It will import C as described in +the documentation below (true for empty list). + +=head2 Like version 0.33 (second incompatible change) + +This API was available from 2011 to 2014. It is widely used in several CPAN +modules and thus it's closest to the current API. It changed the return values +of C, C, and C. It added the C and C functions +and the C alias for C. It omitted C. + + use List::MoreUtils ':like_0.33'; + +This import tag will import all functions available as of version 0.33. Note: +it will not import C for consistency with the 0.33 API. + +=head1 FUNCTIONS + +=head2 Junctions + +=head3 I + +There are two schools of thought for how to evaluate a junction on an +empty list: + +=over + +=item * + +Reduction to an identity (boolean) + +=item * + +Result is undefined (three-valued) + +=back + +In the first case, the result of the junction applied to the empty list is +determined by a mathematical reduction to an identity depending on whether +the underlying comparison is "or" or "and". Conceptually: + + "any are true" "all are true" + -------------- -------------- + 2 elements: A || B || 0 A && B && 1 + 1 element: A || 0 A && 1 + 0 elements: 0 1 + +In the second case, three-value logic is desired, in which a junction +applied to an empty list returns C rather than true or false + +Junctions with a C<_u> suffix implement three-valued logic. Those +without are boolean. + +=head3 all BLOCK LIST + +=head3 all_u BLOCK LIST + +Returns a true value if all items in LIST meet the criterion given through +BLOCK. Sets C<$_> for each item in LIST in turn: + + print "All values are non-negative" + if all { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C returns true (i.e. no values failed the condition) +and C returns C. + +Thus, C<< all_u(@list) >> is equivalent to C<< @list ? all(@list) : undef >>. + +B: because Perl treats C as false, you must check the return value +of C with C or you will get the opposite result of what you +expect. + +=head3 any BLOCK LIST + +=head3 any_u BLOCK LIST + +Returns a true value if any item in LIST meets the criterion given through +BLOCK. Sets C<$_> for each item in LIST in turn: + + print "At least one non-negative value" + if any { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C returns false and C returns C. + +Thus, C<< any_u(@list) >> is equivalent to C<< @list ? any(@list) : undef >>. + +=head3 none BLOCK LIST + +=head3 none_u BLOCK LIST + +Logically the negation of C. Returns a true value if no item in LIST meets +the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn: + + print "No non-negative values" + if none { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C returns true (i.e. no values failed the condition) +and C returns C. + +Thus, C<< none_u(@list) >> is equivalent to C<< @list ? none(@list) : undef >>. + +B: because Perl treats C as false, you must check the return value +of C with C or you will get the opposite result of what you +expect. + +=head3 notall BLOCK LIST + +=head3 notall_u BLOCK LIST + +Logically the negation of C. Returns a true value if not all items in LIST +meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in +turn: + + print "Not all values are non-negative" + if notall { $_ >= 0 } ($x, $y, $z); + +For an empty LIST, C returns false and C returns C. + +Thus, C<< notall_u(@list) >> is equivalent to C<< @list ? notall(@list) : undef >>. + +=head3 one BLOCK LIST + +=head3 one_u BLOCK LIST + +Returns a true value if precisely one item in LIST meets the criterion +given through BLOCK. Sets C<$_> for each item in LIST in turn: + + print "Precisely one value defined" + if one { defined($_) } @list; + +Returns false otherwise. + +For an empty LIST, C returns false and C returns C. + +The expression C is almost equivalent to +C<1 == true BLOCK LIST>, except for short-cutting. +Evaluation of BLOCK will immediately stop at the second true value. + +=head2 Transformation + +=head3 apply BLOCK LIST + +Applies BLOCK to each item in LIST and returns a list of the values after BLOCK +has been applied. In scalar context, the last element is returned. This +function is similar to C but will not modify the elements of the input +list: + + my @list = (1 .. 4); + my @mult = apply { $_ *= 2 } @list; + print "\@list = @list\n"; + print "\@mult = @mult\n"; + __END__ + @list = 1 2 3 4 + @mult = 2 4 6 8 + +Think of it as syntactic sugar for + + for (my @mult = @list) { $_ *= 2 } + +=head3 insert_after BLOCK VALUE LIST + +Inserts VALUE after the first item in LIST for which the criterion in BLOCK is +true. Sets C<$_> for each item in LIST in turn. + + my @list = qw/This is a list/; + insert_after { $_ eq "a" } "longer" => @list; + print "@list"; + __END__ + This is a longer list + +=head3 insert_after_string STRING VALUE LIST + +Inserts VALUE after the first item in LIST which is equal to STRING. + + my @list = qw/This is a list/; + insert_after_string "a", "longer" => @list; + print "@list"; + __END__ + This is a longer list + +=head3 pairwise BLOCK ARRAY1 ARRAY2 + +Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a +new list consisting of BLOCK's return values. The two elements are set to C<$a> +and C<$b>. Note that those two are aliases to the original value so changing +them will modify the input arrays. + + @a = (1 .. 5); + @b = (11 .. 15); + @x = pairwise { $a + $b } @a, @b; # returns 12, 14, 16, 18, 20 + + # mesh with pairwise + @a = qw/a b c/; + @b = qw/1 2 3/; + @x = pairwise { ($a, $b) } @a, @b; # returns a, 1, b, 2, c, 3 + +=head3 mesh ARRAY1 ARRAY2 [ ARRAY3 ... ] + +=head3 zip ARRAY1 ARRAY2 [ ARRAY3 ... ] + +Returns a list consisting of the first elements of each array, then +the second, then the third, etc, until all arrays are exhausted. + +Examples: + + @x = qw/a b c d/; + @y = qw/1 2 3 4/; + @z = mesh @x, @y; # returns a, 1, b, 2, c, 3, d, 4 + + @a = ('x'); + @b = ('1', '2'); + @c = qw/zip zap zot/; + @d = mesh @a, @b, @c; # x, 1, zip, undef, 2, zap, undef, undef, zot + +C is an alias for C. + +=head3 zip6 + +=head3 zip_unflatten + +Returns a list of arrays consisting of the first elements of each array, +then the second, then the third, etc, until all arrays are exhausted. + + @x = qw/a b c d/; + @y = qw/1 2 3 4/; + @z = zip6 @x, @y; # returns [a, 1], [b, 2], [c, 3], [d, 4] + + @a = ('x'); + @b = ('1', '2'); + @c = qw/zip zap zot/; + @d = zip6 @a, @b, @c; # [x, 1, zip], [undef, 2, zap], [undef, undef, zot] + +C is an alias for C. + +=head3 listcmp ARRAY0 ARRAY1 [ ARRAY2 ... ] + +Returns an associative list of elements and every I of the list it +was found in. Allows easy implementation of @a & @b, @a | @b, @a ^ @b and +so on. +Undefined entries in any given array are skipped. + + my @a = qw(one two three four five six seven eight nine ten eleven twelve thirteen); + my @b = qw(two three five seven eleven thirteen seventeen); + my @c = qw(one one two three five eight thirteen twentyone); + my %cmp = listcmp @a, @b, @c; # returns (one => [0, 2], two => [0, 1, 2], three => [0, 1, 2], four => [0], ...) + + my @seq = (1, 2, 3); + my @prim = (undef, 2, 3, 5); + my @fib = (1, 1, 2); + my %cmp = listcmp @seq, @prim, @fib; + # returns ( 1 => [0, 2], 2 => [0, 1, 2], 3 => [0, 1], 5 => [1] ) + +=head3 arrayify LIST[,LIST[,LIST...]] + +Returns a list consisting of each element of given arrays. Recursive arrays +are flattened, too. + + @a = (1, [[2], 3], 4, [5], 6, [7], 8, 9); + @l = arrayify @a; # returns 1, 2, 3, 4, 5, 6, 7, 8, 9 + +=head3 uniq LIST + +=head3 distinct LIST + +Returns a new list by stripping duplicate values in LIST by comparing +the values as hash keys, except that undef is considered separate from ''. +The order of elements in the returned list is the same as in LIST. In +scalar context, returns the number of unique elements in LIST. + + my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4 + my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5 + # returns "Mike", "Michael", "Richard", "Rick" + my @n = distinct "Mike", "Michael", "Richard", "Rick", "Michael", "Rick" + # returns "A8", "", undef, "A5", "S1" + my @s = distinct "A8", "", undef, "A5", "S1", "A5", "A8" + # returns "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C" + my @w = uniq "Giulia", "Giulietta", undef, "", 156, "GTA", "GTV", 159, "Brera", "4C", "Giulietta", "Giulia" + +C is an alias for C. + +B can be used to give feedback about this behavior. + +=head3 singleton LIST + +Returns a new list by stripping values in LIST occurring more than once by +comparing the values as hash keys, except that undef is considered separate +from ''. The order of elements in the returned list is the same as in LIST. +In scalar context, returns the number of elements occurring only once in LIST. + + my @x = singleton 1,1,2,2,3,4,5 # returns 3 4 5 + +=head3 duplicates LIST + +Returns a new list by stripping values in LIST occurring less than twice by +comparing the values as hash keys, except that undef is considered separate +from ''. The order of elements in the returned list is the same as in LIST. +In scalar context, returns the number of elements occurring more than once +in LIST. + + my @y = duplicates 1,1,2,4,7,2,3,4,6,9; #returns 1,2,4 + +=head3 frequency LIST + +Returns an associative list of distinct values and the corresponding frequency. + + my @f = frequency values %radio_nrw; # returns ( + # 'Deutschlandfunk (DLF)' => 9, 'WDR 3' => 10, + # 'WDR 4' => 11, 'WDR 5' => 14, 'WDR Eins Live' => 14, + # 'Deutschlandradio Kultur' => 8,...) + +=head3 occurrences LIST + +Returns a new list of frequencies and the corresponding values from LIST. + + my @o = occurrences ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4); + # @o = (undef, undef, [3, 5], [1], [2, 6], undef, undef, [4]); + +=head3 mode LIST + +Returns the modal value of LIST. In scalar context, just the modal value +is returned, in list context all probes occurring I times are returned, +too. + + my @m = mode ((1) x 3, (2) x 4, (3) x 2, (4) x 7, (5) x 2, (6) x 4, (7) x 3, (8) x 7); + # @m = (7, 4, 8) - bimodal LIST + +=head3 slide BLOCK LIST + +The function C operates on pairs of list elements like: + + my @s = slide { "$a and $b" } (0..3); + # @s = ("0 and 1", "1 and 2", "2 and 3") + +The idea behind this function is a kind of magnifying glass that is moved +along a list and calls C every time the next list item is reached. + +=head2 Partitioning + +=head3 after BLOCK LIST + +Returns a list of the values of LIST after (and not including) the point +where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn. + + @x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9 + +=head3 after_incl BLOCK LIST + +Same as C but also includes the element for which BLOCK is true. + +=head3 before BLOCK LIST + +Returns a list of values of LIST up to (and not including) the point where BLOCK +returns a true value. Sets C<$_> for each element in LIST in turn. + +=head3 before_incl BLOCK LIST + +Same as C but also includes the element for which BLOCK is true. + +=head3 part BLOCK LIST + +Partitions LIST based on the return value of BLOCK which denotes into which +partition the current value is put. + +Returns a list of the partitions thusly created. Each partition created is a +reference to an array. + + my $i = 0; + my @part = part { $i++ % 2 } 1 .. 8; # returns [1, 3, 5, 7], [2, 4, 6, 8] + +You can have a sparse list of partitions as well where non-set partitions will +be undef: + + my @part = part { 2 } 1 .. 10; # returns undef, undef, [ 1 .. 10 ] + +Be careful with negative values, though: + + my @part = part { -1 } 1 .. 10; + __END__ + Modification of non-creatable array value attempted, subscript -1 ... + +Negative values are only ok when they refer to a partition previously created: + + my @idx = ( 0, 1, -1 ); + my $i = 0; + my @part = part { $idx[$i++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8] + +=head3 samples COUNT LIST + +Returns a new list containing COUNT random samples from LIST. Is similar to +L, but stops after COUNT. + + @r = samples 10, 1..10; # same as shuffle + @r2 = samples 5, 1..10; # gives 5 values from 1..10; + +=head2 Iteration + +=head3 each_array ARRAY1 ARRAY2 ... + +Creates an array iterator to return the elements of the list of arrays ARRAY1, +ARRAY2 throughout ARRAYn in turn. That is, the first time it is called, it +returns the first element of each array. The next time, it returns the second +elements. And so on, until all elements are exhausted. + +This is useful for looping over more than one array at once: + + my $ea = each_array(@a, @b, @c); + while ( my ($a, $b, $c) = $ea->() ) { .... } + +The iterator returns the empty list when it reached the end of all arrays. + +If the iterator is passed an argument of 'C', then it returns +the index of the last fetched set of values, as a scalar. + +=head3 each_arrayref LIST + +Like each_array, but the arguments are references to arrays, not the +plain arrays. + +=head3 natatime EXPR, LIST + +Creates an array iterator, for looping over an array in chunks of +C<$n> items at a time. (n at a time, get it?). An example is +probably a better explanation than I could give in words. + +Example: + + my @x = ('a' .. 'g'); + my $it = natatime 3, @x; + while (my @vals = $it->()) + { + print "@vals\n"; + } + +This prints + + a b c + d e f + g + +=head3 slideatatime STEP, WINDOW, LIST + +Creates an array iterator, for looping over an array in chunks of +C<$windows-size> items at a time. + +The idea behind this function is a kind of magnifying glass (finer +controllable compared to L) that is moved along a list. + +Example: + + my @x = ('a' .. 'g'); + my $it = slideatatime 2, 3, @x; + while (my @vals = $it->()) + { + print "@vals\n"; + } + +This prints + + a b c + c d e + e f g + g + +=head2 Searching + +=head3 firstval BLOCK LIST + +=head3 first_value BLOCK LIST + +Returns the first element in LIST for which BLOCK evaluates to true. Each +element of LIST is set to C<$_> in turn. Returns C if no such element +has been found. + +C is an alias for C. + +=head3 onlyval BLOCK LIST + +=head3 only_value BLOCK LIST + +Returns the only element in LIST for which BLOCK evaluates to true. Sets +C<$_> for each item in LIST in turn. Returns C if no such element +has been found. + +C is an alias for C. + +=head3 lastval BLOCK LIST + +=head3 last_value BLOCK LIST + +Returns the last value in LIST for which BLOCK evaluates to true. Each element +of LIST is set to C<$_> in turn. Returns C if no such element has been +found. + +C is an alias for C. + +=head3 firstres BLOCK LIST + +=head3 first_result BLOCK LIST + +Returns the result of BLOCK for the first element in LIST for which BLOCK +evaluates to true. Each element of LIST is set to C<$_> in turn. Returns +C if no such element has been found. + +C is an alias for C. + +=head3 onlyres BLOCK LIST + +=head3 only_result BLOCK LIST + +Returns the result of BLOCK for the first element in LIST for which BLOCK +evaluates to true. Sets C<$_> for each item in LIST in turn. Returns +C if no such element has been found. + +C is an alias for C. + +=head3 lastres BLOCK LIST + +=head3 last_result BLOCK LIST + +Returns the result of BLOCK for the last element in LIST for which BLOCK +evaluates to true. Each element of LIST is set to C<$_> in turn. Returns +C if no such element has been found. + +C is an alias for C. + +=head3 indexes BLOCK LIST + +Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list +of the indices of those elements for which BLOCK returned a true value. This is +just like C only that it returns indices instead of values: + + @x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9 + +=head3 firstidx BLOCK LIST + +=head3 first_index BLOCK LIST + +Returns the index of the first element in LIST for which the criterion in BLOCK +is true. Sets C<$_> for each item in LIST in turn: + + my @list = (1, 4, 3, 2, 4, 6); + printf "item with index %i in list is 4", firstidx { $_ == 4 } @list; + __END__ + item with index 1 in list is 4 + +Returns C<-1> if no such item could be found. + +C is an alias for C. + +=head3 onlyidx BLOCK LIST + +=head3 only_index BLOCK LIST + +Returns the index of the only element in LIST for which the criterion +in BLOCK is true. Sets C<$_> for each item in LIST in turn: + + my @list = (1, 3, 4, 3, 2, 4); + printf "uniqe index of item 2 in list is %i", onlyidx { $_ == 2 } @list; + __END__ + unique index of item 2 in list is 4 + +Returns C<-1> if either no such item or more than one of these +has been found. + +C is an alias for C. + +=head3 lastidx BLOCK LIST + +=head3 last_index BLOCK LIST + +Returns the index of the last element in LIST for which the criterion in BLOCK +is true. Sets C<$_> for each item in LIST in turn: + + my @list = (1, 4, 3, 2, 4, 6); + printf "item with index %i in list is 4", lastidx { $_ == 4 } @list; + __END__ + item with index 4 in list is 4 + +Returns C<-1> if no such item could be found. + +C is an alias for C. + +=head2 Sorting + +=head3 sort_by BLOCK LIST + +Returns the list of values sorted according to the string values returned by the +KEYFUNC block or function. A typical use of this may be to sort objects according +to the string value of some accessor, such as + + sort_by { $_->name } @people + +The key function is called in scalar context, being passed each value in turn as +both $_ and the only argument in the parameters, @_. The values are then sorted +according to string comparisons on the values returned. +This is equivalent to + + sort { $a->name cmp $b->name } @people + +except that it guarantees the name accessor will be executed only once per value. +One interesting use-case is to sort strings which may have numbers embedded in them +"naturally", rather than lexically. + + sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings + +This sorts strings by generating sort keys which zero-pad the embedded numbers to +some level (9 digits in this case), helping to ensure the lexical sort puts them +in the correct order. + +=head3 nsort_by BLOCK LIST + +Similar to sort_by but compares its key values numerically. + +=head3 qsort BLOCK ARRAY + +This sorts the given array B using the given compare code. Except for +tiny compare code like C<< $a <=> $b >>, qsort is much faster than Perl's C +depending on the version. + +Compared 5.8 and 5.26: + + my @rl; + for(my $i = 0; $i < 1E6; ++$i) { push @rl, rand(1E5) } + my $idx; + + sub ext_cmp { $_[0] <=> $_[1] } + + cmpthese( -60, { + 'qsort' => sub { + my @qrl = @rl; + qsort { ext_cmp($a, $b) } @qrl; + $idx = bsearchidx { ext_cmp($_, $rl[0]) } @qrl + }, + 'reverse qsort' => sub { + my @qrl = @rl; + qsort { ext_cmp($b, $a) } @qrl; + $idx = bsearchidx { ext_cmp($rl[0], $_) } @qrl + }, + 'sort' => sub { + my @srl = @rl; + @srl = sort { ext_cmp($a, $b) } @srl; + $idx = bsearchidx { ext_cmp($_, $rl[0]) } @srl + }, + 'reverse sort' => sub { + my @srl = @rl; + @srl = sort { ext_cmp($b, $a) } @srl; + $idx = bsearchidx { ext_cmp($rl[0], $_) } @srl + }, + }); + +5.8 results + + s/iter reverse sort sort reverse qsort qsort + reverse sort 6.21 -- -0% -8% -10% + sort 6.19 0% -- -7% -10% + reverse qsort 5.73 8% 8% -- -2% + qsort 5.60 11% 11% 2% -- + +5.26 results + + s/iter reverse sort sort reverse qsort qsort + reverse sort 4.54 -- -0% -96% -96% + sort 4.52 0% -- -96% -96% + reverse qsort 0.203 2139% 2131% -- -19% + qsort 0.164 2666% 2656% 24% -- + +Use it where external data sources might have to be compared (think of L +"tables"). + +C is available from List::MoreUtils::XS only. It's insane to maintain +a wrapper around Perl's sort nor having a pure Perl implementation. One could +create a flip-book in same speed as PP runs a qsort. + +=head2 Searching in sorted Lists + +=head3 bsearch BLOCK LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in C<$_>) is smaller, +a positive value if it is bigger and zero if it matches. + +Returns a boolean value in scalar context. In list context, it returns the element +if it was found, otherwise the empty list. + +=head3 bsearchidx BLOCK LIST + +=head3 bsearch_index BLOCK LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in C<$_>) is smaller, +a positive value if it is bigger and zero if it matches. + +Returns the index of found element, otherwise C<-1>. + +C is an alias for C. + +=head3 lower_bound BLOCK LIST + +Returns the index of the first element in LIST which does not compare +I. Technically it's the first element in LIST which does +not return a value below zero when passed to BLOCK. + + @ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); + $lb = lower_bound { $_ <=> 2 } @ids; # returns 2 + $lb = lower_bound { $_ <=> 4 } @ids; # returns 10 + +lower_bound has a complexity of O(log n). + +=head3 upper_bound BLOCK LIST + +Returns the index of the first element in LIST which does not compare +I. Technically it's the first element in LIST which does +not return a value below or equal to zero when passed to BLOCK. + + @ids = (1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 7, 7, 7, 8, 8, 9, 9, 9, 9, 9, 11, 13, 13, 13, 17); + $lb = upper_bound { $_ <=> 2 } @ids; # returns 4 + $lb = upper_bound { $_ <=> 4 } @ids; # returns 14 + +upper_bound has a complexity of O(log n). + +=head3 equal_range BLOCK LIST + +Returns a pair of indices containing the lower_bound and the upper_bound. + +=head2 Operations on sorted Lists + +=head3 binsert BLOCK ITEM LIST + +=head3 bsearch_insert BLOCK ITEM LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in C<$_>) is smaller, +a positive value if it is bigger and zero if it matches. + +ITEM is inserted at the index where the ITEM should be placed (based on above +search). That means, it's inserted before the next bigger element. + + @l = (2,3,5,7); + binsert { $_ <=> 4 } 4, @l; # @l = (2,3,4,5,7) + binsert { $_ <=> 6 } 42, @l; # @l = (2,3,4,42,7) + +You take care that the inserted element matches the compare result. + +=head3 bremove BLOCK LIST + +=head3 bsearch_remove BLOCK LIST + +Performs a binary search on LIST which must be a sorted list of values. BLOCK +must return a negative value if the current element (stored in C<$_>) is smaller, +a positive value if it is bigger and zero if it matches. + +The item at the found position is removed and returned. + + @l = (2,3,4,5,7); + bremove { $_ <=> 4 }, @l; # @l = (2,3,5,7); + +=head2 Counting and calculation + +=head3 true BLOCK LIST + +Counts the number of elements in LIST for which the criterion in BLOCK is true. +Sets C<$_> for each item in LIST in turn: + + printf "%i item(s) are defined", true { defined($_) } @list; + +=head3 false BLOCK LIST + +Counts the number of elements in LIST for which the criterion in BLOCK is false. +Sets C<$_> for each item in LIST in turn: + + printf "%i item(s) are not defined", false { defined($_) } @list; + +=head3 reduce_0 BLOCK LIST + +Reduce LIST by calling BLOCK in scalar context for each element of LIST. +C<$a> contains the progressional result and is initialized with 0. +C<$b> contains the current processed element of LIST and C<$_> contains the +index of the element in C<$b>. + +The idea behind reduce_0 is B (addition of a sequence of numbers). + +=head3 reduce_1 BLOCK LIST + +Reduce LIST by calling BLOCK in scalar context for each element of LIST. +C<$a> contains the progressional result and is initialized with 1. +C<$b> contains the current processed element of LIST and C<$_> contains the +index of the element in C<$b>. + +The idea behind reduce_1 is product of a sequence of numbers. + +=head3 reduce_u BLOCK LIST + +Reduce LIST by calling BLOCK in scalar context for each element of LIST. +C<$a> contains the progressional result and is uninitialized. +C<$b> contains the current processed element of LIST and C<$_> contains the +index of the element in C<$b>. + +This function has been added if one might need the extra of the index +value but need an individual initialization. + +B: In most cases L will do the +job better. + +=head3 minmax LIST + +Calculates the minimum and maximum of LIST and returns a two element list with +the first element being the minimum and the second the maximum. Returns the +empty list if LIST was empty. + +The C algorithm differs from a naive iteration over the list where each +element is compared to two values being the so far calculated min and max value +in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient +possible algorithm. + +However, the Perl implementation of it has some overhead simply due to the fact +that there are more lines of Perl code involved. Therefore, LIST needs to be +fairly big in order for C to win over a naive implementation. This +limitation does not apply to the XS version. + +=head3 minmaxstr LIST + +Computes the minimum and maximum of LIST using string compare and returns a +two element list with the first element being the minimum and the second the +maximum. Returns the empty list if LIST was empty. + +The implementation is similar to C. + +=head1 ENVIRONMENT + +When C is set, the module will always use the pure-Perl +implementation and not the XS one. This environment variable is really just +there for the test-suite to force testing the Perl implementation, and possibly +for reporting of bugs. I don't see any reason to use it in a production +environment. + +=head1 MAINTENANCE + +The maintenance goal is to preserve the documented semantics of the API; +bug fixes that bring actual behavior in line with semantics are allowed. +New API functions may be added over time. If a backwards incompatible +change is unavoidable, we will attempt to provide support for the legacy +API using the same export tag mechanism currently in place. + +This module attempts to use few non-core dependencies. Non-core +configuration and testing modules will be bundled when reasonable; +run-time dependencies will be added only if they deliver substantial +benefit. + +=head1 CONTRIBUTING + +While contributions are appreciated, a contribution should not cause more +effort for the maintainer than the contribution itself saves (see +L). + +To get more familiar where help could be needed - see L. + +=head1 BUGS + +There is a problem with a bug in 5.6.x perls. It is a syntax error to write +things like: + + my @x = apply { s/foo/bar/ } qw{ foo bar baz }; + +It has to be written as either + + my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz'; + +or + + my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/; + +Perl 5.5.x and Perl 5.8.x don't suffer from this limitation. + +If you have a functionality that you could imagine being in this module, please +drop me a line. This module's policy will be less strict than L's +when it comes to additions as it isn't a core module. + +When you report bugs, it would be nice if you could additionally give me the +output of your program with the environment variable C set +to a true value. That way I know where to look for the problem (in XS, +pure-Perl or possibly both). + +=head1 SUPPORT + +Bugs should always be submitted via the CPAN bug tracker. + +You can find documentation for this module with the perldoc command. + + perldoc List::MoreUtils + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * MetaCPAN + +L + +=item * CPAN Search + +L + +=item * Git Repository + +L + +=back + +=head2 Where can I go for help? + +If you have a bug report, a patch or a suggestion, please open a new +report ticket at CPAN (but please check previous reports first in case +your issue has already been addressed) or open an issue on GitHub. + +Report tickets should contain a detailed description of the bug or +enhancement request and at least an easily verifiable way of +reproducing the issue or fix. Patches are always welcome, too - and +it's cheap to send pull-requests on GitHub. Please keep in mind that +code changes are more likely accepted when they're bundled with an +approving test. + +If you think you've found a bug then please read +"How to Report Bugs Effectively" by Simon Tatham: +L. + +=head2 Where can I go for help with a concrete version? + +Bugs and feature requests are accepted against the latest version +only. To get patches for earlier versions, you need to get an +agreement with a developer of your choice - who may or not report the +issue and a suggested fix upstream (depends on the license you have +chosen). + +=head2 Business support and maintenance + +Generally, in volunteered projects, there is no right for support. +While every maintainer is happy to improve the provided software, +spare time is limited. + +For those who have a use case which requires guaranteed support, one of +the maintainers should be hired or contracted. For business support you +can contact Jens via his CPAN email address rehsackATcpan.org. Please +keep in mind that business support is neither available for free nor +are you eligible to receive any support based on the license distributed +with this package. + +=head1 THANKS + +=head2 Tassilo von Parseval + +Credits go to a number of people: Steve Purkis for giving me namespace advice +and James Keenan and Terrence Branno for their effort of keeping the CPAN +tidier by making L obsolete. + +Brian McCauley suggested the inclusion of apply() and provided the pure-Perl +implementation for it. + +Eric J. Roode asked me to add all functions from his module C +into this one. With minor modifications, the pure-Perl implementations of those +are by him. + +The bunch of people who almost immediately pointed out the many problems with +the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers). + +A particularly nasty memory leak was spotted by Thomas A. Lowery. + +Lars Thegler made me aware of problems with older Perl versions. + +Anno Siegel de-orphaned each_arrayref(). + +David Filmer made me aware of a problem in each_arrayref that could ultimately +lead to a segfault. + +Ricardo Signes suggested the inclusion of part() and provided the +Perl-implementation. + +Robin Huston kindly fixed a bug in perl's MULTICALL API to make the +XS-implementation of part() work. + +=head2 Jens Rehsack + +Credits goes to all people contributing feedback during the v0.400 +development releases. + +Special thanks goes to David Golden who spent a lot of effort to develop +a design to support current state of CPAN as well as ancient software +somewhere in the dark. He also contributed a lot of patches to refactor +the API frontend to welcome any user of List::MoreUtils - from ancient +past to recently last used. + +Toby Inkster provided a lot of useful feedback for sane importer code +and was a nice sounding board for API discussions. + +Peter Rabbitson provided a sane git repository setup containing entire +package history. + +=head1 TODO + +A pile of requests from other people is still pending further processing in +my mailbox. This includes: + +=over 4 + +=item * delete_index + +=item * random_item + +=item * random_item_delete_index + +=item * list_diff_hash + +=item * list_diff_inboth + +=item * list_diff_infirst + +=item * list_diff_insecond + +These were all suggested by Dan Muey. + +=item * listify + +Always return a flat list when either a simple scalar value was passed or an +array-reference. Suggested by Mark Summersault. + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Jens Rehsack Erehsack AT cpan.orgE + +Adam Kennedy Eadamk@cpan.orgE + +Tassilo von Parseval Etassilo.von.parseval@rwth-aachen.deE + +=head1 COPYRIGHT AND LICENSE + +Some parts copyright 2011 Aaron Crane. + +Copyright 2004 - 2010 by Tassilo von Parseval + +Copyright 2013 - 2017 by Jens Rehsack + +All code added with 0.417 or later is licensed under the Apache License, +Version 2.0 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +All code until 0.416 is licensed under the same terms as Perl itself, +either Perl version 5.8.4 or, at your option, any later version of +Perl 5 you may have available. + +=cut + +1; Index: synthetic_sim/perl_lib/Number/Compare.pm =================================================================== --- synthetic_sim/perl_lib/Number/Compare.pm (nonexistent) +++ synthetic_sim/perl_lib/Number/Compare.pm (revision 56) @@ -0,0 +1,99 @@ +package Number::Compare; +use strict; +use Carp qw(croak); +use vars qw/$VERSION/; +$VERSION = '0.03'; + +sub new { + my $referent = shift; + my $class = ref $referent || $referent; + my $expr = $class->parse_to_perl( shift ); + + bless eval "sub { \$_[0] $expr }", $class; +} + +sub parse_to_perl { + shift; + my $test = shift; + + $test =~ m{^ + ([<>]=?)? # comparison + (.*?) # value + ([kmg]i?)? # magnitude + $}ix + or croak "don't understand '$test' as a test"; + + my $comparison = $1 || '=='; + my $target = $2; + my $magnitude = $3 || ''; + $target *= 1000 if lc $magnitude eq 'k'; + $target *= 1024 if lc $magnitude eq 'ki'; + $target *= 1000000 if lc $magnitude eq 'm'; + $target *= 1024*1024 if lc $magnitude eq 'mi'; + $target *= 1000000000 if lc $magnitude eq 'g'; + $target *= 1024*1024*1024 if lc $magnitude eq 'gi'; + + return "$comparison $target"; +} + +sub test { $_[0]->( $_[1] ) } + +1; + +__END__ + +=head1 NAME + +Number::Compare - numeric comparisons + +=head1 SYNOPSIS + + Number::Compare->new(">1Ki")->test(1025); # is 1025 > 1024 + + my $c = Number::Compare->new(">1M"); + $c->(1_200_000); # slightly terser invocation + +=head1 DESCRIPTION + +Number::Compare compiles a simple comparison to an anonymous +subroutine, which you can call with a value to be tested again. + +Now this would be very pointless, if Number::Compare didn't understand +magnitudes. + +The target value may use magnitudes of kilobytes (C, C), +megabytes (C, C), or gigabytes (C, C). Those suffixed +with an C use the appropriate 2**n version in accordance with the +IEC standard: http://physics.nist.gov/cuu/Units/binary.html + +=head1 METHODS + +=head2 ->new( $test ) + +Returns a new object that compares the specified test. + +=head2 ->test( $value ) + +A longhanded version of $compare->( $value ). Predates blessed +subroutine reference implementation. + +=head2 ->parse_to_perl( $test ) + +Returns a perl code fragment equivalent to the test. + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2002,2011 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +http://physics.nist.gov/cuu/Units/binary.html + +=cut Index: synthetic_sim/perl_lib/Proc/Background/Unix.pm =================================================================== --- synthetic_sim/perl_lib/Proc/Background/Unix.pm (nonexistent) +++ synthetic_sim/perl_lib/Proc/Background/Unix.pm (revision 56) @@ -0,0 +1,300 @@ +package Proc::Background::Unix; +$Proc::Background::Unix::VERSION = '1.30'; +# ABSTRACT: Unix-specific implementation of process create/wait/kill +require 5.004_04; + +use strict; +use Exporter; +use Carp; +use POSIX qw( :errno_h :sys_wait_h ); + +# Test for existence of FD_CLOEXEC, needed for child-error-through-pipe trick +my ($FD_CLOEXEC); +eval { + require Fcntl; + $FD_CLOEXEC= Fcntl::FD_CLOEXEC(); +}; + +# For un-explained mysterious reasons, Time::HiRes::alarm seem to misbehave on 5.10 and earlier +# but core alarm works fine. +my $alarm= ($] >= 5.012)? do { require Time::HiRes; \&Time::HiRes::alarm; } + : sub { + # round up to whole seconds + CORE::alarm(POSIX::ceil($_[0])); + }; + +@Proc::Background::Unix::ISA = qw(Exporter); + +# Start the background process. If it is started sucessfully, then record +# the process id in $self->{_os_obj}. +sub _start { + my ($self, $options)= @_; + + # There are three main scenarios for how-to-exec: + # * single-string command, to be handled by shell + # * arrayref command, to be handled by execve + # * arrayref command with 'exe' (fake argv0) + # and one that isn't logical: + # * single-string command with exe + # throw an error for that last one rather than trying something awkward + # like splitting the command string. + + my @argv; + my $cmd= $self->{_command}; + my $exe= $self->{_exe}; + + if (ref $cmd eq 'ARRAY') { + @argv= @$cmd; + ($exe, my $err) = Proc::Background::_resolve_path(defined $exe? $exe : $argv[0]); + return $self->_fatal($err) unless defined $exe; + $self->{_exe}= $exe; + } elsif (defined $exe) { + croak "Can't combine 'exe' option with single-string 'command', use arrayref 'command' instead."; + } + + if (defined $options->{cwd}) { + -d $options->{cwd} + or return $self->_fatal("directory does not exist: '$options->{cwd}'"); + } + + my ($new_stdin, $new_stdout, $new_stderr); + $new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN) + if exists $options->{stdin}; + $new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT) + if exists $options->{stdout}; + $new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR) + if exists $options->{stderr}; + + # Fork a child process. + my ($pipe_r, $pipe_w); + if (defined $FD_CLOEXEC) { + # use a pipe for the child to report exec() errors + pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!"); + # This pipe needs to be in the non-preserved range that doesn't exist after exec(). + # In the edge case where a pipe received a FD less than $^F, the CLOEXEC flag isn't set. + # Try again on higher descriptors, then close the lower ones. + my @rejects; + while (fileno $pipe_r <= $^F or fileno $pipe_w <= $^F) { + push @rejects, $pipe_r, $pipe_w; + pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!"); + } + } + my $pid; + { + if ($pid = fork()) { + # parent + $self->{_os_obj} = $pid; + $self->{_pid} = $pid; + if (defined $pipe_r) { + close $pipe_w; + # wait for child to reply or close the pipe + local $SIG{PIPE}= sub {}; + my $msg= ''; + while (0 < read $pipe_r, $msg, 1024, length $msg) {} + close $pipe_r; + # If child wrote anything to the pipe, it failed to exec. + # Reap it before dying. + if (length $msg) { + waitpid $pid, 0; + return $self->_fatal($msg); + } + } + last; + } elsif (defined $pid) { + # child + # Make absolutely sure nothing in this block interacts with the rest of the + # process state, and that flow control never skips the _exit(). + eval { + local $SIG{__DIE__}= undef; + eval { + chdir($options->{cwd}) or die "chdir($options->{cwd}): $!\n" + if defined $options->{cwd}; + + open STDIN, '<&', $new_stdin or die "Can't redirect STDIN: $!\n" + if defined $new_stdin; + open STDOUT, '>&', $new_stdout or die "Can't redirect STDOUT: $!\n" + if defined $new_stdout; + open STDERR, '>&', $new_stderr or die "Can't redirect STDERR: $!\n" + if defined $new_stderr; + + if (defined $exe) { + exec { $exe } @argv or die "$0: exec failed: $!\n"; + } else { + exec $cmd or die "$0: exec failed: $!\n"; + } + }; + if (defined $pipe_w) { + print $pipe_w $@; + close $pipe_w; # force it to flush. Nothing else needs closed because we are about to _exit + } else { + print STDERR $@; + } + }; + POSIX::_exit(1); + } elsif ($! == EAGAIN) { + sleep 5; + redo; + } else { + return $self->_fatal("fork: $!"); + } + } + + $self; +} + +sub _resolve_file_handle { + my ($thing, $mode, $default)= @_; + if (!defined $thing) { + open my $fh, $mode, '/dev/null' or croak "open(/dev/null): $!"; + return $fh; + } elsif (ref $thing) { + # use 'undef' to mean no-change + return (fileno($thing) == fileno($default))? undef : $thing; + } else { + open my $fh, $mode, $thing or croak "open($thing): $!"; + return $fh; + } +} + +# Wait for the child. +# (0, exit_value) : sucessfully waited on. +# (1, undef) : process already reaped and exit value lost. +# (2, undef) : process still running. +sub _waitpid { + my ($self, $blocking, $wait_seconds) = @_; + + { + # Try to wait on the process. + # Implement the optional timeout with the 'alarm' call. + my $result= 0; + if ($blocking && $wait_seconds) { + local $SIG{ALRM}= sub { die "alarm\n" }; + $alarm->($wait_seconds); + eval { $result= waitpid($self->{_os_obj}, 0); }; + $alarm->(0); + } + else { + $result= waitpid($self->{_os_obj}, $blocking? 0 : WNOHANG); + } + + # Process finished. Grab the exit value. + if ($result == $self->{_os_obj}) { + delete $self->{_suspended}; + return (0, $?); + } + # Process already reaped. We don't know the exist status. + elsif ($result == -1 and $! == ECHILD) { + return (1, 0); + } + # Process still running. + elsif ($result == 0) { + return (2, 0); + } + # If we reach here, then waitpid caught a signal, so let's retry it. + redo; + } + return 0; +} + +sub _suspend { + kill STOP => $_[0]->{_os_obj}; +} + +sub _resume { + kill CONT => $_[0]->{_os_obj}; +} + +sub _terminate { + my $self = shift; + my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 ); + # Try to kill the process with different signals. Calling alive() will + # collect the exit status of the program. + while (@kill_sequence and $self->alive) { + my $sig= shift @kill_sequence; + my $delay= shift @kill_sequence; + kill($sig, $self->{_os_obj}); + next unless defined $delay; + last if $self->_reap(1, $delay); # block before sending next signal + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Proc::Background::Unix - Unix-specific implementation of process create/wait/kill + +=head1 DESCRIPTION + +This module does not have a public interface. Use L. + +=head1 NAME + +Proc::Background::Unix - Implementation of process management for Unix systems + +=head1 IMPLEMENTATION + +=head2 Command vs. Exec + +Unix systems start a new process by creating a mirror of the current process +(C) and then having it alter its own state to prepare for the new +program, and then calling C to replace the running code with code loaded +from a new file. However, there is a second common method where the user +wants to specify a command line string as they would type it in their shell. +In this case, the actual program being executed is the shell, and the command +line is given as one element of its argument list. + +Perl already supports both methods, such that if you pass one string to C +containing shell characters, it calls the shell, and if you pass multiple +arguments, it directly invokes C. + +This module mostly just lets Perl's C do its job, but also checks for +the existence of the executable first, to make errors easier to catch. This +check is skipped if there is a single-string command line. + +Unix lets you run a different executable than what is listed in the first +argument. (this feature lets one Unix executable behave as multiple +different programs depending on what name it sees in the first argument) +You can use that feature by passing separate options of C and C +to this module's constructor instead of a simple argument list. But, you +can't mix a C option with a shell-interpreted command line string. + +=head2 Errors during Exec + +If the C option is enabled, and the system supports C, +this module uses a trick where the forked child relays any errors through +a pipe so that the parent can throw and handle the exception directly instead +of creating a child process that is dead-on-arrival with the error on STDERR. + +=head1 AUTHORS + +=over 4 + +=item * + +Blair Zajac + +=item * + +Michael Conrad + +=back + +=head1 VERSION + +version 1.30 + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2021 by Michael Conrad, (C) 1998-2009 by Blair Zajac. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut Index: synthetic_sim/perl_lib/Proc/Background.pm =================================================================== --- synthetic_sim/perl_lib/Proc/Background.pm (nonexistent) +++ synthetic_sim/perl_lib/Proc/Background.pm (revision 56) @@ -0,0 +1,721 @@ +package Proc::Background; +$Proc::Background::VERSION = '1.30'; +# ABSTRACT: Generic interface to Unix and Win32 background process management +require 5.004_04; + +use strict; +use Exporter; +use Carp; +use Cwd; +use Scalar::Util; +@Proc::Background::ISA = qw(Exporter); +@Proc::Background::EXPORT_OK = qw(timeout_system); + +# Determine if the operating system is Windows. +my $is_windows = $^O eq 'MSWin32'; +my $weaken_subref = Scalar::Util->can('weaken'); + +# Set up a regular expression that tests if the path is absolute and +# if it has a directory separator in it. Also create a list of file +# extensions of append to the programs name to look for the real +# executable. +my $is_absolute_re; +my $has_dir_element_re; +my $path_sep; +my @extensions = (''); +if ($is_windows) { + $is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))'; + $has_dir_element_re = "[\\\\/]"; + $path_sep = "\\"; + push(@extensions, '.exe'); +} else { + $is_absolute_re = "^/"; + $has_dir_element_re = "/"; + $path_sep = "/"; +} + +# Make this class a subclass of Proc::Win32 or Proc::Unix. Any +# unresolved method calls will go to either of these classes. +if ($is_windows) { + require Proc::Background::Win32; + unshift(@Proc::Background::ISA, 'Proc::Background::Win32'); +} else { + require Proc::Background::Unix; + unshift(@Proc::Background::ISA, 'Proc::Background::Unix'); +} + +# Take either a relative or absolute path to a command and make it an +# absolute path. +sub _resolve_path { + my $command = shift; + + return ( undef, 'empty command string' ) unless length $command; + + # Make the path to the progam absolute if it isn't already. If the + # path is not absolute and if the path contains a directory element + # separator, then only prepend the current working to it. If the + # path is not absolute, then look through the PATH environment to + # find the executable. In all cases, look for the programs with any + # extensions added to the original path name. + my $path; + if ($command =~ /$is_absolute_re/o) { + foreach my $ext (@extensions) { + my $p = "$command$ext"; + if (-f $p and -x _) { + $path = $p; + last; + } + } + return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" ); + } else { + my $cwd = cwd; + if ($command =~ /$has_dir_element_re/o) { + my $p1 = "$cwd$path_sep$command"; + foreach my $ext (@extensions) { + my $p2 = "$p1$ext"; + if (-f $p2 and -x _) { + $path = $p2; + last; + } + } + } else { + foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) { + next unless length $dir; + $dir = "$cwd$path_sep$dir" unless $dir =~ /$is_absolute_re/o; + my $p1 = "$dir$path_sep$command"; + foreach my $ext (@extensions) { + my $p2 = "$p1$ext"; + if (-f $p2 and -x _) { + $path = $p2; + last; + } + } + last if defined $path; + } + } + return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" ); + } +} + +# Define the set of allowed options, to warn about unknown ones. +# Make it a method so subclasses can override it. +%Proc::Background::_available_options= ( + autodie => 1, command => 1, exe => 1, + cwd => 1, stdin => 1, stdout => 1, stderr => 1, + autoterminate => 1, die_upon_destroy => 1, +); + +sub _available_options { + return \%Proc::Background::_available_options; +} + +# We want the created object to live in Proc::Background instead of +# the OS specific class so that generic method calls can be used. +sub new { + my $class = shift; + + # The parameters are an optional %options hashref followed by any number + # of arguments to become the @argv for exec(). If options are given, check + # the keys for typos. + my $options; + if (@_ and ref $_[0] eq 'HASH') { + $options= shift; + my $known= $class->_available_options; + my @unknown= grep !$known->{$_}, keys %$options; + carp "Unknown options: ".join(', ', @unknown) + if @unknown; + } + else { + $options= {}; + } + + my $self= bless {}, $class; + $self->{_autodie}= 1 if $options->{autodie}; + + # Resolve any confusion between the 'command' option and positional @argv params. + # Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have + # to deal with it redundantly. + my $cmd= $options->{command}; + if (defined $cmd) { + croak "Can't use both 'command' option and command argument list" + if @_; + # Can be an arrayref or a single string + croak "command must be a non-empty string or an arrayref of strings" + unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0]) + or (!ref $cmd && defined $cmd && length $cmd); + } + else { + # Back-compat: maintain original API quirks + confess "Proc::Background::new called with insufficient number of arguments" + unless @_; + return $self->_fatal('command is undefined') unless defined $_[0]; + + # Interpret the parameters as an @argv if there is more than one, + # or if the 'exe' option was given. + $cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0]; + } + + $self->{_command}= $cmd; + $self->{_exe}= $options->{exe} if defined $options->{exe}; + + # Also back-compat: failing to fork or CreateProcess returns undef + return unless $self->_start($options); + + # Save the start time + $self->{_start_time} = time; + + if ($options->{autoterminate} || $options->{die_upon_destroy}) { + $self->autoterminate(1); + } + + return $self; +} + +# The original API returns undef from the constructor in case of various errors. +# The autodie option converts these undefs into exceptions. +sub _fatal { + my ($self, $message)= @_; + croak $message if $self->{_autodie}; + warn "$0: $message"; + return undef; +} + +sub autoterminate { + my ($self, $newval)= @_; + if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) { + if ($newval) { + # Global destruction can break this feature, because there are no guarantees + # on which order object destructors are called. In order to avoid that, need + # to run all the ->die methods during END{}, and that requires weak + # references which weren't available until 5.8 + $weaken_subref->( $Proc::Background::_die_upon_destroy{$self+0}= $self ) + if $weaken_subref; + # could warn about it for earlier perl... but has been broken for 15 years and + # who is still using < 5.8 anyway? + } + else { + delete $Proc::Background::_die_upon_destroy{$self+0}; + } + $self->{_die_upon_destroy}= $newval? 1 : 0; + } + $self->{_die_upon_destroy} || 0 +} + +sub DESTROY { + my $self = shift; + if ($self->{_die_upon_destroy}) { + # During a mainline exit() $? is the prospective exit code from the + # parent program. Preserve it across any waitpid() in die() + local $?; + $self->terminate; + delete $Proc::Background::_die_upon_destroy{$self+0}; + } +} + +END { + # Child processes need killed before global destruction, else the + # Win32::Process objects might get destroyed first. + for (grep defined, values %Proc::Background::_die_upon_destroy) { + $_->terminate; + delete $_->{_die_upon_destroy} + } + %Proc::Background::_die_upon_destroy= (); +} + +# Reap the child. If the first argument is false, then return immediately. +# Else, block waiting for the process to exit. If no second argument is +# given, wait forever, else wait for that number of seconds. +# If the wait was sucessful, then delete +# $self->{_os_obj} and set $self->{_exit_value} to the OS specific +# class return of _reap. Return 1 if we sucessfully waited, 0 +# otherwise. +sub _reap { + my ($self, $blocking, $wait_seconds) = @_; + + return 0 unless exists($self->{_os_obj}); + + # Try to wait on the process. Use the OS dependent wait call using + # the Proc::Background::*::waitpid call, which returns one of three + # values. + # (0, exit_value) : sucessfully waited on. + # (1, undef) : process already reaped and exit value lost. + # (2, undef) : process still running. + my ($result, $exit_value) = $self->_waitpid($blocking, $wait_seconds); + if ($result == 0 or $result == 1) { + $self->{_exit_value} = defined($exit_value) ? $exit_value : 0; + delete $self->{_os_obj}; + # Save the end time of the class. + $self->{_end_time} = time; + return 1; + } + return 0; +} + +sub alive { + my $self = shift; + + # If $self->{_os_obj} is not set, then the process is definitely + # not running. + return 0 unless exists($self->{_os_obj}); + + # If $self->{_exit_value} is set, then the process has already finished. + return 0 if exists($self->{_exit_value}); + + # Try to reap the child. If it doesn't reap, then it's alive. + !$self->_reap(0); +} + +sub suspended { + $_[0]->{_suspended}? 1 : 0 +} + +sub suspend { + my $self= shift; + return $self->_fatal("can't suspend, process has exited") + if !$self->{_os_obj}; + $self->{_suspended} = 1 if $self->_suspend; + return $self->{_suspended}; +} + +sub resume { + my $self= shift; + return $self->_fatal("can't resume, process has exited") + if !$self->{_os_obj}; + $self->{_suspended} = 0 if $self->_resume; + return !$self->{_suspended}; +} + +sub wait { + my ($self, $timeout_seconds) = @_; + + # If $self->{_exit_value} exists, then we already waited. + return $self->{_exit_value} if exists($self->{_exit_value}); + + carp "calling ->wait on a suspended process" if $self->{_suspended}; + + # If neither _os_obj or _exit_value are set, then something is wrong. + return undef if !exists($self->{_os_obj}); + + # Otherwise, wait for the process to finish. + return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef; +} + +sub terminate { shift->die(@_) } +sub die { + my $self = shift; + + croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj}; + + # See if the process has already died. + return 1 unless $self->alive; + + # Kill the process using the OS specific method. + $self->_terminate(@_? ([ @_ ]) : ()); + + # See if the process is still alive. + !$self->alive; +} + +sub command { + $_[0]->{_command}; +} + +sub exe { + $_[0]->{_exe} +} + +sub start_time { + $_[0]->{_start_time}; +} + +sub exit_code { + return undef unless exists $_[0]->{_exit_value}; + return $_[0]->{_exit_value} >> 8; +} + +sub exit_signal { + return undef unless exists $_[0]->{_exit_value}; + return $_[0]->{_exit_value} & 127; +} + +sub end_time { + $_[0]->{_end_time}; +} + +sub pid { + $_[0]->{_pid}; +} + +sub timeout_system { + unless (@_ > 1) { + confess "$0: timeout_system passed too few arguments.\n"; + } + + my $timeout = shift; + unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) { + confess "$0: timeout_system passed a non-positive number first argument.\n"; + } + + my $proc = Proc::Background->new(@_) or return; + my $end_time = $proc->start_time + $timeout; + my $delay= $timeout; + while ($delay > 0 && defined $proc->{_os_obj}) { + last if defined $proc->wait($delay); + # If it times out, it's likely that wait() already waited the entire duration. + # But, if it got interrupted, there might be time remaining. + # But, if the system clock changes, this could break horribly. Constrain it to a sane value. + my $t= time; + if ($t < $end_time - $delay) { # time moved backward! + $end_time= $t + $delay; + } else { + $delay= $end_time - $t; + } + } + + my $alive = $proc->alive; + $proc->terminate if $alive; + + if (wantarray) { + return ($proc->wait, $alive); + } else { + return $proc->wait; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Proc::Background - Generic interface to Unix and Win32 background process management + +=head1 SYNOPSIS + + use Proc::Background; + timeout_system($seconds, $command, $arg1, $arg2); + timeout_system($seconds, "$command $arg1 $arg2"); + + my $proc1 = Proc::Background->new($command, $arg1, $arg2) || die "failed"; + my $proc2 = Proc::Background->new("$command $arg1 1>&2") || die "failed"; + if ($proc1->alive) { + $proc1->terminate; + $proc1->wait; + } + say 'Ran for ' . ($proc1->end_time - $proc1->start_time) . ' seconds'; + + Proc::Background->new({ + autodie => 1, # Throw exceptions instead of returning undef + cwd => 'some/path/', # Set working directory for the new process + exe => 'busybox', # Specify executable different from argv[0] + command => [ $command ] # resolve ambiguity of command line vs. argv[0] + }); + + # Set initial file handles + Proc::Background->new({ + stdin => undef, # /dev/null or NUL + stdout => '/append/to/fname', # will try to open() + stderr => $log_fh, # use existing handle + command => \@command, + }); + + # Automatically kill the process if the object gets destroyed + my $proc4 = Proc::Background->new({ autoterminate => 1 }, $command); + $proc4 = undef; # calls ->terminate + +=head1 DESCRIPTION + +This is a generic interface for placing processes in the background on +both Unix and Win32 platforms. This module lets you start, kill, wait +on, retrieve exit values, and see if background processes still exist. + +=head1 CONSTRUCTOR + +=over 4 + +=item B [options] I, [I, [I, ...]] + +=item B [options] 'I [I [I ...]]' + +This creates a new background process. Just like C, you can +supply a single string of the entire command line, or individual +arguments. The first argument may be a hashref of named options. +To resolve the ambiguity between a command line vs. a single-element +argument list, see the C option below. + +By default, the constructor returns an empty list on failure, +except for a few cases of invalid arguments which call C. + +For platform-specific details, see L +or L, but in short: + +=over 7 + +=item Unix + +This implementation uses C/C. If you supply a single-string +command line, it is passed to the shell. If you supply multiple arguments, +they are passed to C. In the multi-argument case, it will also check +that the executable exists before calling C. + +=item Win32 + +This implementation uses the L. +If you supply a single-string command line, it derives the executable by +parsing the command line and looking for the first element in the C, +appending C<".exe"> if needed. If you supply multiple arguments, the +first is used as the C and the command line is built using +L. + +=back + +B + +=over + +=item C + +This module traditionally has returned C if the child could not +be started. Modern Perl recommends the use of exceptions for things +like this. This option, like Perl's L pragma, causes all +fatal errors in starting the process to die with exceptions instead of +returning undef. + +=item C + +You may specify the command as an option instead of passing the command +as a list. A string value is considered a command line, and an arrayref +value is considered an argument list. This can resolve the ambiguity +between a command line vs. single-element argument list. + +=item C + +Specify the executable. This can serve two purposes: +on Win32 it avoids the parsing of the commandline, and on Unix it can be +used to run an executable while passing a different value for C<$ARGV[0]>. + +=item C, C, C + +Specify one or more overrides for the standard handles of the child. +The value should be a Perl filehandle with an underlying system C +value. As a convenience, you can pass C to open the C device +on Win32 or C on Unix. You may also pass a plain-scalar file +name which this module will attmept to open for reading or appending. + +(for anything more elaborate, see L instead) + +Note that on Win32, none of the parent's handles are inherited by default, +which is the opposite on Unix. When you specify any of these handles on +Win32 the default will change to inherit them from the parent. + +=item C + +Specify a path which should become the child process's current working +directory. The path must already exist. + +=item C + +If you pass a true value for this option, then destruction of the +Proc::Background object (going out of scope, or script-end) will kill the +process via C<< ->terminate >>. Without this option, the child process +continues running. C is an alias for this option, used +by previous versions of this module. + +=back + +=back + +=head1 ATTRIBUTES + +=over + +=item B + +The command (string or arrayref) that was passed to the constructor. + +=item B + +The path to the executable that was passed as an option to the constructor, +or derived from the C. + +=item B + +Return the value that the Perl function time() returned when the +process was started. + +=item B + +Returns the process ID of the created process. This value is saved +even if the process has already finished. + +=item B + +Return 1 if the process is still active, 0 otherwise. This makes a +non-blocking call to C to check the real status of the process if it +has not been reaped yet. + +=item B + +Boolean whether the process is thought to be stopped. This does not actually +consult the operating system, and just returns the last known status from a +call to C or C. It is always false if C is false. + +=item B + +Returns the exit code of the process, assuming it exited cleanly. +Returns C if the process has not exited yet, and 0 if the +process exited with a signal (or TerminateProcess). Since 0 is +ambiguous, check for C first. + +=item B + +Returns the value of the signal the process exited with, assuming it +died on a signal. Returns C if it has not exited yet, and 0 +if it did not die to a signal. + +=item B + +Return the value that the Perl function time() returned when the exit +status was obtained from the process. + +=item B + +This writeable attribute lets you enable or disable the autoterminate +option, which could also be passed to the constructor. + +=back + +=head1 METHODS + +=over + +=item B + + $exit= $proc->wait; # blocks forever + $exit= $proc->wait($timeout_seconds); # since version 1.20 + +Wait for the process to exit. Return the exit status of the command +as returned by wait() on the system. To get the actual exit value, +divide by 256 or right bit shift by 8, regardless of the operating +system being used. If the process never existed, this returns undef. +This function may be called multiple times even after the process has +exited and it will return the same exit status. + +Since version 1.20, you may pass an optional argument of the number of +seconds to wait for the process to exit. This may be fractional, and +if it is zero then the wait will be non-blocking. Note that on Unix +this is implemented with L before a call to wait(), +so it may not be compatible with scripts that use alarm() for other +purposes, or systems/perls that resume system calls after a signal. +In the event of a timeout, the return will be undef. + +=item B + +Pause the process. This returns true if the process is stopped afterward. +This throws an excetion if the process is not C and C is +enabled. + +=item B + +Resume a paused process. This returns true if the process is not stopped +afterward. This throws an exception if the process is not C and +C is enabled. + +=item B, B + +Reliably try to kill the process. Returns 1 if the process no longer +exists once B has completed, 0 otherwise. This will also return +1 if the process has already exited. + +C<@kill_sequence> is a list of actions and seconds-to-wait for that +action to end the process. The default is C< TERM 2 TERM 8 KILL 3 KILL 7 >. +On Unix this sends SIGTERM and SIGKILL; on Windows it just calls +TerminateProcess (graceful terminationthe second is set to 1 if the process was killed by +B or 0 if the process exited by itself. + +The exit status is the value returned from the wait() call. If the +process was killed, then the return value will include the killing of +it. To get the actual exit value, divide by 256. + +If something failed in the creation of the process, the subroutine +returns an empty list in a list context, an undefined value in a +scalar context, or nothing in a void context. + +=back + +=head1 SEE ALSO + +=over + +=item L + +IPC::Run is a much more complete solution for running child processes. +It handles dozens of forms of redirection and pipe pumping, and should +probably be your first stop for any complex needs. + +However, also note the very large and slightly alarming list of +limitations it lists for Win32. Proc::Background is a much simpler design +and should be more reliable for simple needs. + +=item L + +If you are running on Win32, this article by Daniel Colascione helps +describe the problem you are up against for passing argument lists: +L + +This module gives you parsing / quoting per the standard +CommandLineToArgvW behavior. But, if you need to pass arguments to be +processed by C then you need to do additional work. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Blair Zajac + +=item * + +Michael Conrad + +=back + +=head1 CONTRIBUTORS + +=for stopwords Florian Schlichting Kevin Ryde Salvador Fandiño + +=over 4 + +=item * + +Florian Schlichting + +=item * + +Kevin Ryde + +=item * + +Salvador Fandiño + +=back + +=head1 VERSION + +version 1.30 + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2021 by Michael Conrad, (C) 1998-2009 by Blair Zajac. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut Index: synthetic_sim/perl_lib/String/MANIFEST =================================================================== --- synthetic_sim/perl_lib/String/MANIFEST (nonexistent) +++ synthetic_sim/perl_lib/String/MANIFEST (revision 56) @@ -0,0 +1,11 @@ +README +Changes +MANIFEST +COPYING +Makefile.PL +Similarity.pm +Similarity.xs +fstrcmp.h fstrcmp (from gnu gettext) +fstrcmp.c fstrcmp (from gnu gettext) +t/00_load.t +META.yml Module meta-data (added by MakeMaker) Index: synthetic_sim/perl_lib/String/META.yml =================================================================== --- synthetic_sim/perl_lib/String/META.yml (nonexistent) +++ synthetic_sim/perl_lib/String/META.yml (revision 56) @@ -0,0 +1,20 @@ +--- #YAML:1.0 +name: String-Similarity +version: 1.04 +abstract: ~ +author: [] +license: unknown +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + ExtUtils::MakeMaker: 0 +requires: {} +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.50 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 Index: synthetic_sim/perl_lib/String/Makefile.PL =================================================================== --- synthetic_sim/perl_lib/String/Makefile.PL (nonexistent) +++ synthetic_sim/perl_lib/String/Makefile.PL (revision 56) @@ -0,0 +1,14 @@ +require 5.008; + +use ExtUtils::MakeMaker; + +WriteMakefile( + dist => { + PREOP => 'pod2text Similarity.pm | tee README >$(DISTVNAME)/README; chmod -R u=rwX,go=rX . ;', + COMPRESS => 'gzip -9v', + SUFFIX => '.gz', + }, + NAME => "String::Similarity", + VERSION_FROM => "Similarity.pm", +); + Index: synthetic_sim/perl_lib/String/Similarity.pm =================================================================== --- synthetic_sim/perl_lib/String/Similarity.pm (nonexistent) +++ synthetic_sim/perl_lib/String/Similarity.pm (revision 56) @@ -0,0 +1,79 @@ +=head1 NAME + +String::Similarity - calculate the similarity of two strings + +=head1 SYNOPSIS + + use String::Similarity; + + $similarity = similarity $string1, $string2; + $similarity = similarity $string1, $string2, $limit; + +=head1 DESCRIPTION + +=over 4 + +=cut + +package String::Similarity; + +use Exporter; +use DynaLoader; + +$VERSION = '1.04'; +@ISA = qw/Exporter DynaLoader/; +@EXPORT = qw(similarity); +@EXPORT_OK = qw(fstrcmp); + +bootstrap String::Similarity $VERSION; + +=item $factor = similarity $string1, $string2, [$limit] + +The C-function calculates the similarity index of +its two arguments. A value of C<0> means that the strings are +entirely different. A value of C<1> means that the strings are +identical. Everything else lies between 0 and 1 and describes the amount +of similarity between the strings. + +It roughly works by looking at the smallest number of edits to change one +string into the other. + +You can add an optional argument C<$limit> (default 0) that gives the +minimum similarity the two strings must satisfy. C stops +analyzing the string as soon as the result drops below the given limit, +in which case the result will be invalid but lower than the given +C<$limit>. You can use this to speed up the common case of searching for +the most similar string from a set by specifing the maximum similarity +found so far. + +=cut + +# out of historical reasons, I prefer "fstrcmp" as the original name. +*similarity = *fstrcmp; + +1; + +=back + +=head1 SEE ALSO + + The basic algorithm is described in: + "An O(ND) Difference Algorithm and its Variations", Eugene Myers, + Algorithmica Vol. 1 No. 2, 1986, pp. 251-266; + see especially section 4.2, which describes the variation used below. + + The basic algorithm was independently discovered as described in: + "Algorithms for Approximate String Matching", E. Ukkonen, + Information and Control Vol. 64, 1985, pp. 100-118. + +=head1 AUTHOR + + Marc Lehmann + http://home.schmorp.de/ + + (the underlying fstrcmp function was taken from gnu diffutils and + modified by Peter Miller and Marc Lehmann + ). + + +
synthetic_sim/perl_lib/String/Similarity.pm Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: synthetic_sim/perl_lib/String/Similarity.xs =================================================================== --- synthetic_sim/perl_lib/String/Similarity.xs (nonexistent) +++ synthetic_sim/perl_lib/String/Similarity.xs (revision 56) @@ -0,0 +1,54 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "fstrcmp.h" +#include "fstrcmp.c" + +UV * +text2UV (SV *sv, STRLEN *lenp) +{ + STRLEN len; + char *s = SvPV (sv, len); + UV *r = (UV *)SvPVX (sv_2mortal (NEWSV (0, (len + 1) * sizeof (UV)))); + UV *p = r; + + if (SvUTF8 (sv)) + { + STRLEN clen; + while (len) + { + *p++ = utf8n_to_uvchr (s, len, &clen, 0); + + if (clen < 0) + croak ("illegal unicode character in string"); + + s += clen; + len -= clen; + } + } + else + while (len--) + *p++ = *(unsigned char *)s++; + + *lenp = p - r; + return r; +} + +MODULE = String::Similarity PACKAGE = String::Similarity + +double +fstrcmp(s1, s2, minimum_similarity = 0) + SV * s1 + SV * s2 + double minimum_similarity + PROTOTYPE: @ + CODE: +{ + STRLEN l1, l2; + UV *c1 = text2UV (s1, &l1); + UV *c2 = text2UV (s2, &l2); + RETVAL = fstrcmp (c1, l1, c2, l2, minimum_similarity); +} + OUTPUT: + RETVAL Index: synthetic_sim/perl_lib/String/fstrcmp.c =================================================================== --- synthetic_sim/perl_lib/String/fstrcmp.c (nonexistent) +++ synthetic_sim/perl_lib/String/fstrcmp.c (revision 56) @@ -0,0 +1,638 @@ +/* Functions to make fuzzy comparisons between strings + Copyright (C) 1988, 1989, 1992, 1993, 1995 Free Software Foundation, Inc. + + This program 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 of the License, or (at + your option) any later version. + + This program 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 this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + + Derived from GNU diff 2.7, analyze.c et al. + + The basic algorithm is described in: + "An O(ND) Difference Algorithm and its Variations", Eugene Myers, + Algorithmica Vol. 1 No. 2, 1986, pp. 251-266; + see especially section 4.2, which describes the variation used below. + + The basic algorithm was independently discovered as described in: + "Algorithms for Approximate String Matching", E. Ukkonen, + Information and Control Vol. 64, 1985, pp. 100-118. + + Modified to work on strings rather than files + by Peter Miller , October 1995 + + Modified to accept a "minimum similarity limit" to stop analyzing the + string when the similarity drops below the given limit by Marc Lehmann + . + + Modified to work on unicode (actually 31 bit are allowed) by Marc Lehmann + . +*/ + +#include +#include +#include +#include + +#include "fstrcmp.h" + +#define PARAMS(proto) proto + +/* + * Data on one input string being compared. + */ +struct string_data +{ + /* The string to be compared. */ + const UV *data; + + /* The length of the string to be compared. */ + int data_length; + + /* The number of characters inserted or deleted. */ + int edit_count; +}; + +static struct string_data string[2]; + +static int max_edits; /* compareseq stops when edits > max_edits */ + +#ifdef MINUS_H_FLAG + +/* This corresponds to the diff -H flag. With this heuristic, for + strings with a constant small density of changes, the algorithm is + linear in the strings size. This is unlikely in typical uses of + fstrcmp, and so is usually compiled out. Besides, there is no + interface to set it true. */ +static int heuristic; + +#endif + + +/* Vector, indexed by diagonal, containing 1 + the X coordinate of the + point furthest along the given diagonal in the forward search of the + edit matrix. */ +static int *fdiag; + +/* Vector, indexed by diagonal, containing the X coordinate of the point + furthest along the given diagonal in the backward search of the edit + matrix. */ +static int *bdiag; + +/* Edit scripts longer than this are too expensive to compute. */ +static int too_expensive; + +/* Snakes bigger than this are considered `big'. */ +#define SNAKE_LIMIT 20 + +struct partition +{ + /* Midpoints of this partition. */ + int xmid, ymid; + + /* Nonzero if low half will be analyzed minimally. */ + int lo_minimal; + + /* Likewise for high half. */ + int hi_minimal; +}; + + +/* NAME + diag - find diagonal path + + SYNOPSIS + int diag(int xoff, int xlim, int yoff, int ylim, int minimal, + struct partition *part); + + DESCRIPTION + Find the midpoint of the shortest edit script for a specified + portion of the two strings. + + Scan from the beginnings of the strings, and simultaneously from + the ends, doing a breadth-first search through the space of + edit-sequence. When the two searches meet, we have found the + midpoint of the shortest edit sequence. + + If MINIMAL is nonzero, find the minimal edit script regardless + of expense. Otherwise, if the search is too expensive, use + heuristics to stop the search and report a suboptimal answer. + + RETURNS + Set PART->(XMID,YMID) to the midpoint (XMID,YMID). The diagonal + number XMID - YMID equals the number of inserted characters + minus the number of deleted characters (counting only characters + before the midpoint). Return the approximate edit cost; this is + the total number of characters inserted or deleted (counting + only characters before the midpoint), unless a heuristic is used + to terminate the search prematurely. + + Set PART->LEFT_MINIMAL to nonzero iff the minimal edit script + for the left half of the partition is known; similarly for + PART->RIGHT_MINIMAL. + + CAVEAT + This function assumes that the first characters of the specified + portions of the two strings do not match, and likewise that the + last characters do not match. The caller must trim matching + characters from the beginning and end of the portions it is + going to specify. + + If we return the "wrong" partitions, the worst this can do is + cause suboptimal diff output. It cannot cause incorrect diff + output. */ + +static int diag PARAMS ((int, int, int, int, int, struct partition *)); + +static int +diag (xoff, xlim, yoff, ylim, minimal, part) + int xoff; + int xlim; + int yoff; + int ylim; + int minimal; + struct partition *part; +{ + int *const fd = fdiag; /* Give the compiler a chance. */ + int *const bd = bdiag; /* Additional help for the compiler. */ + const UV *const xv = string[0].data; /* Still more help for the compiler. */ + const UV *const yv = string[1].data; /* And more and more . . . */ + const int dmin = xoff - ylim; /* Minimum valid diagonal. */ + const int dmax = xlim - yoff; /* Maximum valid diagonal. */ + const int fmid = xoff - yoff; /* Center diagonal of top-down search. */ + const int bmid = xlim - ylim; /* Center diagonal of bottom-up search. */ + int fmin = fmid; + int fmax = fmid; /* Limits of top-down search. */ + int bmin = bmid; + int bmax = bmid; /* Limits of bottom-up search. */ + int c; /* Cost. */ + int odd = (fmid - bmid) & 1; + + /* + * True if southeast corner is on an odd diagonal with respect + * to the northwest. + */ + fd[fmid] = xoff; + bd[bmid] = xlim; + for (c = 1;; ++c) + { + int d; /* Active diagonal. */ + int big_snake; + + big_snake = 0; + /* Extend the top-down search by an edit step in each diagonal. */ + if (fmin > dmin) + fd[--fmin - 1] = -1; + else + ++fmin; + if (fmax < dmax) + fd[++fmax + 1] = -1; + else + --fmax; + for (d = fmax; d >= fmin; d -= 2) + { + int x; + int y; + int oldx; + int tlo; + int thi; + + tlo = fd[d - 1], + thi = fd[d + 1]; + + if (tlo >= thi) + x = tlo + 1; + else + x = thi; + oldx = x; + y = x - d; + while (x < xlim && y < ylim && xv[x] == yv[y]) + { + ++x; + ++y; + } + if (x - oldx > SNAKE_LIMIT) + big_snake = 1; + fd[d] = x; + if (odd && bmin <= d && d <= bmax && bd[d] <= x) + { + part->xmid = x; + part->ymid = y; + part->lo_minimal = part->hi_minimal = 1; + return 2 * c - 1; + } + } + /* Similarly extend the bottom-up search. */ + if (bmin > dmin) + bd[--bmin - 1] = INT_MAX; + else + ++bmin; + if (bmax < dmax) + bd[++bmax + 1] = INT_MAX; + else + --bmax; + for (d = bmax; d >= bmin; d -= 2) + { + int x; + int y; + int oldx; + int tlo; + int thi; + + tlo = bd[d - 1], + thi = bd[d + 1]; + if (tlo < thi) + x = tlo; + else + x = thi - 1; + oldx = x; + y = x - d; + while (x > xoff && y > yoff && xv[x - 1] == yv[y - 1]) + { + --x; + --y; + } + if (oldx - x > SNAKE_LIMIT) + big_snake = 1; + bd[d] = x; + if (!odd && fmin <= d && d <= fmax && x <= fd[d]) + { + part->xmid = x; + part->ymid = y; + part->lo_minimal = part->hi_minimal = 1; + return 2 * c; + } + } + + if (minimal) + continue; + +#ifdef MINUS_H_FLAG + /* Heuristic: check occasionally for a diagonal that has made lots + of progress compared with the edit distance. If we have any + such, find the one that has made the most progress and return + it as if it had succeeded. + + With this heuristic, for strings with a constant small density + of changes, the algorithm is linear in the strings size. */ + if (c > 200 && big_snake && heuristic) + { + int best; + + best = 0; + for (d = fmax; d >= fmin; d -= 2) + { + int dd; + int x; + int y; + int v; + + dd = d - fmid; + x = fd[d]; + y = x - d; + v = (x - xoff) * 2 - dd; + + if (v > 12 * (c + (dd < 0 ? -dd : dd))) + { + if + ( + v > best + && + xoff + SNAKE_LIMIT <= x + && + x < xlim + && + yoff + SNAKE_LIMIT <= y + && + y < ylim + ) + { + /* We have a good enough best diagonal; now insist + that it end with a significant snake. */ + int k; + + for (k = 1; xv[x - k] == yv[y - k]; k++) + { + if (k == SNAKE_LIMIT) + { + best = v; + part->xmid = x; + part->ymid = y; + break; + } + } + } + } + } + if (best > 0) + { + part->lo_minimal = 1; + part->hi_minimal = 0; + return 2 * c - 1; + } + best = 0; + for (d = bmax; d >= bmin; d -= 2) + { + int dd; + int x; + int y; + int v; + + dd = d - bmid; + x = bd[d]; + y = x - d; + v = (xlim - x) * 2 + dd; + + if (v > 12 * (c + (dd < 0 ? -dd : dd))) + { + if (v > best && xoff < x && x <= xlim - SNAKE_LIMIT && + yoff < y && y <= ylim - SNAKE_LIMIT) + { + /* We have a good enough best diagonal; now insist + that it end with a significant snake. */ + int k; + + for (k = 0; xv[x + k] == yv[y + k]; k++) + { + if (k == SNAKE_LIMIT - 1) + { + best = v; + part->xmid = x; + part->ymid = y; + break; + } + } + } + } + } + if (best > 0) + { + part->lo_minimal = 0; + part->hi_minimal = 1; + return 2 * c - 1; + } + } +#endif /* MINUS_H_FLAG */ + + /* Heuristic: if we've gone well beyond the call of duty, give up + and report halfway between our best results so far. */ + if (c >= too_expensive) + { + int fxybest; + int fxbest; + int bxybest; + int bxbest; + + /* Pacify `gcc -Wall'. */ + fxbest = 0; + bxbest = 0; + + /* Find forward diagonal that maximizes X + Y. */ + fxybest = -1; + for (d = fmax; d >= fmin; d -= 2) + { + int x; + int y; + + x = fd[d] < xlim ? fd[d] : xlim; + y = x - d; + + if (ylim < y) + { + x = ylim + d; + y = ylim; + } + if (fxybest < x + y) + { + fxybest = x + y; + fxbest = x; + } + } + /* Find backward diagonal that minimizes X + Y. */ + bxybest = INT_MAX; + for (d = bmax; d >= bmin; d -= 2) + { + int x; + int y; + + x = xoff > bd[d] ? xoff : bd[d]; + y = x - d; + + if (y < yoff) + { + x = yoff + d; + y = yoff; + } + if (x + y < bxybest) + { + bxybest = x + y; + bxbest = x; + } + } + /* Use the better of the two diagonals. */ + if ((xlim + ylim) - bxybest < fxybest - (xoff + yoff)) + { + part->xmid = fxbest; + part->ymid = fxybest - fxbest; + part->lo_minimal = 1; + part->hi_minimal = 0; + } + else + { + part->xmid = bxbest; + part->ymid = bxybest - bxbest; + part->lo_minimal = 0; + part->hi_minimal = 1; + } + return 2 * c - 1; + } + } +} + + +/* NAME + compareseq - find edit sequence + + SYNOPSIS + void compareseq(int xoff, int xlim, int yoff, int ylim, int minimal); + + DESCRIPTION + Compare in detail contiguous subsequences of the two strings + which are known, as a whole, to match each other. + + The subsequence of string 0 is [XOFF, XLIM) and likewise for + string 1. + + Note that XLIM, YLIM are exclusive bounds. All character + numbers are origin-0. + + If MINIMAL is nonzero, find a minimal difference no matter how + expensive it is. */ + +static void compareseq PARAMS ((int, int, int, int, int)); + +static void +compareseq (xoff, xlim, yoff, ylim, minimal) + int xoff; + int xlim; + int yoff; + int ylim; + int minimal; +{ + const UV *const xv = string[0].data; /* Help the compiler. */ + const UV *const yv = string[1].data; + + if (string[1].edit_count + string[0].edit_count > max_edits) + return; + + /* Slide down the bottom initial diagonal. */ + while (xoff < xlim && yoff < ylim && xv[xoff] == yv[yoff]) + { + ++xoff; + ++yoff; + } + + /* Slide up the top initial diagonal. */ + while (xlim > xoff && ylim > yoff && xv[xlim - 1] == yv[ylim - 1]) + { + --xlim; + --ylim; + } + + /* Handle simple cases. */ + if (xoff == xlim) + { + while (yoff < ylim) + { + ++string[1].edit_count; + ++yoff; + } + } + else if (yoff == ylim) + { + while (xoff < xlim) + { + ++string[0].edit_count; + ++xoff; + } + } + else + { + int c; + struct partition part; + + /* Find a point of correspondence in the middle of the strings. */ + c = diag (xoff, xlim, yoff, ylim, minimal, &part); + if (c == 1) + { +#if 0 + /* This should be impossible, because it implies that one of + the two subsequences is empty, and that case was handled + above without calling `diag'. Let's verify that this is + true. */ + abort (); +#else + /* The two subsequences differ by a single insert or delete; + record it and we are done. */ + if (part.xmid - part.ymid < xoff - yoff) + ++string[1].edit_count; + else + ++string[0].edit_count; +#endif + } + else + { + /* Use the partitions to split this problem into subproblems. */ + compareseq (xoff, part.xmid, yoff, part.ymid, part.lo_minimal); + compareseq (part.xmid, xlim, part.ymid, ylim, part.hi_minimal); + } + } +} + + +/* NAME + fstrcmp - fuzzy string compare + + SYNOPSIS + double fstrcmp(const ChaR *s1, int l1, const UV *s2, int l2, double); + + DESCRIPTION + The fstrcmp function may be used to compare two string for + similarity. It is very useful in reducing "cascade" or + "secondary" errors in compilers or other situations where + symbol tables occur. + + RETURNS + double; 0 if the strings are entirly dissimilar, 1 if the + strings are identical, and a number in between if they are + similar. */ + +double +fstrcmp (const UV *string1, int length1, + const UV *string2, int length2, + double minimum) +{ + int i; + + size_t fdiag_len; + static int *fdiag_buf; + static size_t fdiag_max; + + /* set the info for each string. */ + string[0].data = string1; + string[0].data_length = length1; + string[1].data = string2; + string[1].data_length = length2; + + /* short-circuit obvious comparisons */ + if (string[0].data_length == 0 && string[1].data_length == 0) + return 1.0; + if (string[0].data_length == 0 || string[1].data_length == 0) + return 0.0; + + /* Set TOO_EXPENSIVE to be approximate square root of input size, + bounded below by 256. */ + too_expensive = 1; + for (i = string[0].data_length + string[1].data_length; i != 0; i >>= 2) + too_expensive <<= 1; + if (too_expensive < 256) + too_expensive = 256; + + /* Because fstrcmp is typically called multiple times, while scanning + symbol tables, etc, attempt to minimize the number of memory + allocations performed. Thus, we use a static buffer for the + diagonal vectors, and never free them. */ + fdiag_len = string[0].data_length + string[1].data_length + 3; + if (fdiag_len > fdiag_max) + { + fdiag_max = fdiag_len; + fdiag_buf = realloc (fdiag_buf, fdiag_max * (2 * sizeof (int))); + } + fdiag = fdiag_buf + string[1].data_length + 1; + bdiag = fdiag + fdiag_len; + + max_edits = 1 + (string[0].data_length + string[1].data_length) * (1. - minimum); + + /* Now do the main comparison algorithm */ + string[0].edit_count = 0; + string[1].edit_count = 0; + compareseq (0, string[0].data_length, 0, string[1].data_length, 0); + + /* The result is + ((number of chars in common) / (average length of the strings)). + This is admittedly biased towards finding that the strings are + similar, however it does produce meaningful results. */ + return ((double) + (string[0].data_length + string[1].data_length - string[1].edit_count - string[0].edit_count) + / (string[0].data_length + string[1].data_length)); + +} Index: synthetic_sim/perl_lib/String/fstrcmp.h =================================================================== --- synthetic_sim/perl_lib/String/fstrcmp.h (nonexistent) +++ synthetic_sim/perl_lib/String/fstrcmp.h (revision 56) @@ -0,0 +1,25 @@ +/* GNU gettext - internationalization aids + Copyright (C) 1995 Free Software Foundation, Inc. + + This file was written by Peter Miller + +This program 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. + +This program 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 this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifndef _FSTRCMP_H +#define _FSTRCMP_H + +double fstrcmp (const UV *__s1, int __l1, const UV *__s2, int __l2, double __minimum); + +#endif Index: synthetic_sim/perl_lib/Text/Glob.pm =================================================================== --- synthetic_sim/perl_lib/Text/Glob.pm (nonexistent) +++ synthetic_sim/perl_lib/Text/Glob.pm (revision 56) @@ -0,0 +1,202 @@ +package Text::Glob; +use strict; +use Exporter; +use vars qw/$VERSION @ISA @EXPORT_OK + $strict_leading_dot $strict_wildcard_slash/; +$VERSION = '0.11'; +@ISA = 'Exporter'; +@EXPORT_OK = qw( glob_to_regex glob_to_regex_string match_glob ); + +$strict_leading_dot = 1; +$strict_wildcard_slash = 1; + +use constant debug => 0; + +sub glob_to_regex { + my $glob = shift; + my $regex = glob_to_regex_string($glob); + return qr/^$regex$/; +} + +sub glob_to_regex_string +{ + my $glob = shift; + + my $seperator = $Text::Glob::seperator; + $seperator = "/" unless defined $seperator; + $seperator = quotemeta($seperator); + + my ($regex, $in_curlies, $escaping); + local $_; + my $first_byte = 1; + for ($glob =~ m/(.)/gs) { + if ($first_byte) { + if ($strict_leading_dot) { + $regex .= '(?=[^\.])' unless $_ eq '.'; + } + $first_byte = 0; + } + if ($_ eq '/') { + $first_byte = 1; + } + if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || + $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { + $regex .= "\\$_"; + } + elsif ($_ eq '*') { + $regex .= $escaping ? "\\*" : + $strict_wildcard_slash ? "(?:(?!$seperator).)*" : ".*"; + } + elsif ($_ eq '?') { + $regex .= $escaping ? "\\?" : + $strict_wildcard_slash ? "(?!$seperator)." : "."; + } + elsif ($_ eq '{') { + $regex .= $escaping ? "\\{" : "("; + ++$in_curlies unless $escaping; + } + elsif ($_ eq '}' && $in_curlies) { + $regex .= $escaping ? "}" : ")"; + --$in_curlies unless $escaping; + } + elsif ($_ eq ',' && $in_curlies) { + $regex .= $escaping ? "," : "|"; + } + elsif ($_ eq "\\") { + if ($escaping) { + $regex .= "\\\\"; + $escaping = 0; + } + else { + $escaping = 1; + } + next; + } + else { + $regex .= $_; + $escaping = 0; + } + $escaping = 0; + } + print "# $glob $regex\n" if debug; + + return $regex; +} + +sub match_glob { + print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; + my $glob = shift; + my $regex = glob_to_regex $glob; + local $_; + grep { $_ =~ $regex } @_; +} + +1; +__END__ + +=head1 NAME + +Text::Glob - match globbing patterns against text + +=head1 SYNOPSIS + + use Text::Glob qw( match_glob glob_to_regex ); + + print "matched\n" if match_glob( "foo.*", "foo.bar" ); + + # prints foo.bar and foo.baz + my $regex = glob_to_regex( "foo.*" ); + for ( qw( foo.bar foo.baz foo bar ) ) { + print "matched: $_\n" if /$regex/; + } + +=head1 DESCRIPTION + +Text::Glob implements glob(3) style matching that can be used to match +against text, rather than fetching names from a filesystem. If you +want to do full file globbing use the File::Glob module instead. + +=head2 Routines + +=over + +=item match_glob( $glob, @things_to_test ) + +Returns the list of things which match the glob from the source list. + +=item glob_to_regex( $glob ) + +Returns a compiled regex which is the equivalent of the globbing +pattern. + +=item glob_to_regex_string( $glob ) + +Returns a regex string which is the equivalent of the globbing +pattern. + +=back + +=head1 SYNTAX + +The following metacharacters and rules are respected. + +=over + +=item C<*> - match zero or more characters + +C matches C, C, C and many many more. + +=item C - match exactly one character + +C matches C, but not C, or C + +=item Character sets/ranges + +C matches C and C + +C matches C, C, and C + +=item alternation + +C matches C, C, and +C + +=item leading . must be explicitly matched + +C<*.foo> does not match C<.bar.foo>. For this you must either specify +the leading . in the glob pattern (C<.*.foo>), or set +C<$Text::Glob::strict_leading_dot> to a false value while compiling +the regex. + +=item C<*> and C do not match the seperator (i.e. do not match C) + +C<*.foo> does not match C. For this you must either +explicitly match the / in the glob (C<*/*.foo>), or set +C<$Text::Glob::strict_wildcard_slash> to a false value while compiling +the regex, or change the seperator that Text::Glob uses by setting +C<$Text::Glob::seperator> to an alternative value while compiling the +the regex. + +=back + +=head1 BUGS + +The code uses qr// to produce compiled regexes, therefore this module +requires perl version 5.005_03 or newer. + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2006, 2007 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L, glob(3) + +=cut Index: synthetic_sim/perl_lib/constant/boolean.pm =================================================================== --- synthetic_sim/perl_lib/constant/boolean.pm (nonexistent) +++ synthetic_sim/perl_lib/constant/boolean.pm (revision 56) @@ -0,0 +1,104 @@ +#!/usr/bin/perl -c + +package constant::boolean; + +=head1 NAME + +constant::boolean - Define TRUE and FALSE constants. + +=head1 SYNOPSIS + + use constant::boolean; + + use File::Spec; + + sub is_package_exist { + my ($package) = @_; + return FALSE unless defined $package; + foreach my $inc (@INC) { + my $filename = File::Spec->catfile( + split( /\//, $inc ), split( /\::/, $package ) + ) . '.pm'; + return TRUE if -f $filename; + }; + return FALSE; + }; + + no constant::boolean; + +=head1 DESCRIPTION + +Defines C and C constants in caller's namespace. You could use +simple values like empty string or zero for false, or any non-empty and +non-zero string value as true, but the C and C constants are more +descriptive. + +It is virtually the same as: + + # double "not" operator is used for converting scalar to boolean value + use constant TRUE => !! 1; + use constant FALSE => !! ''; + +The constants exported by C are not reported by +L, so it is more convenient to use this module than to +define C and C constants by yourself. + +The constants can be removed from class API with C +pragma or some universal tool like L. + +=for readme stop + +=cut + +use 5.006; + +use strict; +use warnings; + +our $VERSION = '0.02'; + + +sub import { + my $caller = caller; + + no strict 'refs'; + # double "not" operator is used for converting scalar to boolean value + *{"${caller}::TRUE"} = sub () { !! 1 }; + *{"${caller}::FALSE"} = sub () { !! '' }; + + return 1; +}; + + +sub unimport { + require Symbol::Util; + + my $caller = caller; + Symbol::Util::delete_sub("${caller}::$_") foreach qw( TRUE FALSE ); + + return 1; +}; + + +1; + + +=head1 BUGS + +If you find the bug or want to implement new features, please report it at +L + +=for readme continue + +=head1 AUTHOR + +Piotr Roszatycki + +=head1 LICENSE + +Copyright 2008, 2009 by Piotr Roszatycki . + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L Index: synthetic_sim/report =================================================================== --- synthetic_sim/report (revision 55) +++ synthetic_sim/report (revision 56) @@ -1,9 +1,13 @@ Verification Results: -****************************mesh_4x4_2cycle_mcast_f : Compile *******************************: - model is generated successfully. -****************************mesh_4x4_2cycle_mcast_f : random traffic *******************************: - Passed: zero load (5,15.2151) saturation (30,357.163) -****************************mesh_4x4_2cycle_mcast_f : transposed 1 traffic *******************************: - Error in running simulation: 0: ERROR: Routing module did not set any destination port for an injected multicast packet TOP.router_top_v.router.router_ref.p_[0].multi.multicast_process.debg - 0: ERROR: The self-loop is not enabled in the router while a packet is injected to the NoC with identical source and destination address in endpoint 9. destination nodes:0X0200. : TOP.traffic_gen_top - +****************************star_6 : Compile *******************************: + model generation is FAILED. + %Error: Unknown warning specified: -Wno-TIMESCALEMOD + + %Error: Unknown warning specified: -Wno-TIMESCALEMOD + + %Error: Unknown warning specified: -Wno-TIMESCALEMOD + +****************************star_6 : random traffic *******************************: + failed. Simulation model is not avaialable +****************************star_6 : transposed 1 traffic *******************************: + failed. Simulation model is not avaialable Index: synthetic_sim/src/src.pl =================================================================== --- synthetic_sim/src/src.pl (revision 55) +++ synthetic_sim/src/src.pl (revision 56) @@ -1,7 +1,11 @@ #!/usr/bin/perl -w +use lib "../perl_lib"; + +use List::MoreUtils qw(uniq); use Proc::Background; use File::Path qw( rmtree ); +use Cwd 'abs_path'; my $script_path = dirname(__FILE__); my $dirname = "$script_path/.."; @@ -14,7 +18,7 @@ my $src = "$script_path"; my $report = "$dirname/report"; -require "$root/perl_gui/lib/perl/common.pl"; +#require "$root/perl_gui/lib/perl/common.pl"; require "$root/perl_gui/lib/perl/topology.pl"; use strict; @@ -318,6 +322,17 @@ } +sub check_models_are_exsited { + my ($mref, $inref) = @_; + my @models = get_model_names(@_); + foreach my $m (@models){ + unless (-f $m ){ + die "Error: no such file $m"; + } + } +} + + sub gen_models { my ($mref, $inref) = @_; my @models = get_model_names(@_); @@ -326,6 +341,9 @@ mkdir("$work", 0700); foreach my $m (@models){ print "$m\n"; + unless (-f $m ){ + die "Error: no such file $m"; + } #make noc localparam my $o; $o= do $m; @@ -605,3 +623,204 @@ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="passed"; } + +sub object_get_attribute_order{ + my ($self,$attribute)=@_; + return unless(defined $self->{parameters_order}{$attribute}); + my @order=@{$self->{parameters_order}{$attribute}}; + return uniq(@order) +} + +sub save_file { + my ($file_path,$text)=@_; + open my $fd, ">$file_path" or die "could not open $file_path: $!"; + print $fd $text; + close $fd; +} + +sub object_add_attribute_order{ + my ($self,$attribute,@param)=@_; + my $r = $self->{'parameters_order'}{$attribute}; + my @a; + @a = @{$r} if(defined $r); + push (@a,@param); + @a=uniq(@a); + $self->{'parameters_order'}{$attribute} =\@a; +} + +sub append_text_to_file { + my ($file_path,$text)=@_; + open(my $fd, ">>$file_path") or die "could not open $file_path: $!"; + print $fd $text; + close $fd; +} + +sub object_add_attribute{ + my ($self,$attribute1,$attribute2,$value)=@_; + if(!defined $attribute2){$self->{$attribute1}=$value;} + else {$self->{$attribute1}{$attribute2}=$value;} + +} + + + +sub object_get_attribute{ + my ($self,$attribute1,$attribute2)=@_; + if(!defined $attribute2) {return $self->{$attribute1};} + return $self->{$attribute1}{$attribute2}; +} + +sub powi{ # x^y + my ($x,$y)=@_; # compute x to the y + my $r=1; + for (my $i = 0; $i < $y; ++$i ) { + $r *= $x; + } + return $r; +} + +sub sum_powi{ # x^(y-1) + x^(y-2) + ...+ 1; + my ($x,$y)=@_; # compute x to the y + my $r = 0; + for (my $i = 0; $i < $y; $i++){ + $r += powi( $x, $i ); + } + return $r; +} + +sub log2{ + my $num=shift; + my $log=($num <=1) ? 1: 0; + while( (1<< $log) < $num) { + $log++; + } + return $log; +} + + +sub remove_not_hex { + my $s=shift; + $s =~ s/[^0-9a-fA-F]//g; + return $s; +} + +sub remove_not_number { + my $s=shift; + $s =~ s/[^0-9]//g; + return $s; + +} + +sub check_file_has_string { + my ($file,$string)=@_; + my $r; + open(FILE,$file); + if (grep{/$string/} ){ + $r= 1; #print "word found\n"; + }else{ + $r= 0; #print "word not found\n"; + } + close FILE; + return $r; +} + + +sub gen_verilator_makefile{ + my ($top_ref,$target_dir) =@_; + my %tops = %{$top_ref}; + my $p=''; + my $q=''; + my $h=''; + my $l; + my $lib_num=0; + my $all_lib=""; + foreach my $top (sort keys %tops) { + $p = "$p ${top}__ALL.a "; + $q = $q."lib$lib_num:\n\t\$(MAKE) -f ${top}.mk\n"; + $h = "$h ${top}.h "; + $l = $top; + $all_lib=$all_lib." lib$lib_num"; + $lib_num++; + } + + my $make= " + +default: sim + + + +include $l.mk + +lib: $all_lib + +$q + + +####################################################################### +# Compile flags + +CPPFLAGS += -DVL_DEBUG=1 +ifeq (\$(CFG_WITH_CCWARN),yes) # Local... Else don't burden users +CPPFLAGS += -DVL_THREADED=1 +CPPFLAGS += -W -Werror -Wall +endif + +SLIB = +HLIB = +ifneq (\$(wildcard synful/synful.a),) +SLIB += synful/synful.a +HLIB += synful/synful.h +endif + +####################################################################### +# Linking final exe -- presumes have a sim_main.cpp + + +sim: testbench.o \$(VK_GLOBAL_OBJS) $p \$(SLIB) + \$(LINK) \$(LDFLAGS) -g \$^ \$(LOADLIBES) \$(LDLIBS) -o testbench \$(LIBS) -Wall -O3 -lpthread 2>&1 | c++filt + +testbench.o: testbench.cpp $h \$(HLIB) + +clean: + rm *.o *.a testbench +"; + +save_file ($target_dir,$make); + +} + + +sub get_project_dir{ #mpsoc directory address + my $dir = Cwd::getcwd(); + my @p= split('/perl_gui',$dir); + @p= split('/Integration_test',$p[0]); + my $d = abs_path("$p[0]/../"); + + return $d; +} + +#return lines containig pattern in a givn file +sub unix_grep { + my ($file,$pattern)=@_; + open(FILE,$file); + my @arr = ; + my @lines = grep /$pattern/, @arr; + return @lines; +} + + +sub regen_object { + my $path=shift; + $path = get_full_path_addr($path); + my $pp= eval { do $path }; + my $r= ($@ || !defined $pp); + return ($pp,$r,$@); +} + +sub get_full_path_addr{ + my $file=shift; + my $dir = Cwd::getcwd(); + my $full_path = "$dir/$file"; + return $full_path if -f ($full_path ); + return $file; +}
/synthetic_sim/verify.perl
2,6 → 2,7
package ProNOC;
 
use Getopt::Std;
use lib perl_lib;
 
 
# perl verify.pl [model-name] p min max step
45,23 → 46,23
}
 
 
if (defined $options{h} ) {
if (defined $options{h} ) {
print " Usage: perl verify.pl [options]
-h show this help
-h show this help
-p <int number> : Enter the number of parallel simulations or
compilations. The default value is 4.
-u <int number> : Enter the maximum injection ratio in %. Default is 80
-l <int number> : Enter the minimum injection ratio in %. Default is 5
-s <int number> : Enter the injection step increase ratio in %.
-s <int number> : Enter the injection step increase ratio in %.
Default value is 25.
-d <dir name> : The dir name where the simulation models configuration
files are located in. The default dir is \"models\"
-m <simulation model name1,simulation model name2,...> : Enter the
files are located in. The default dir is \"models\"
-m <simulation model name1,simulation model name2,...> : Enter the
simulation model name in simulation dir. If the simulation model name
is not provided, it runs the simulation for all
is not provided, it runs the simulation for all
existing models.
";
exit;
exit;
}
 
my $paralel_run= 4;
80,7 → 81,7
$model_dir = $options{d} if defined $options{d};
 
if (defined $options{m}){
@models = split(",",$options{m});
@models = split(",",$options{m});
}
 
 
91,7 → 92,7
 
 
__PACKAGE__->mk_accessors(qw{
models
models
});
 
my $app = __PACKAGE__->new();
108,11 → 109,14
print "Maximum number of parallel simulation is $paralel_run.\n The injection ratio is set as MIN=$MIN,MAX=$MAX,STEP=$STEP.\n";
print "\t The simulation models are taken from $model_dir\n";
if (defined $options{m}){
foreach my $p (@models ){ print "\t\t$p\n";}
foreach my $p (@models ){
print "\t\t$p\n";
}
}
 
my @log_report_match =("Error","Warning" );
check_models_are_exsited(\@models,\@inputs);
 
my @log_report_match =("Error","Warning" );
 
 
save_file ("$dirname/report","Verification Results:\n");

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.