diff --git a/SOURCES/Backport-Perl4-CoreLibs.patch b/SOURCES/Backport-Perl4-CoreLibs.patch new file mode 100644 index 0000000..97919ec --- /dev/null +++ b/SOURCES/Backport-Perl4-CoreLibs.patch @@ -0,0 +1,2484 @@ +diff -ENwbur perl-5.16.3-orig/lib/abbrev.pl perl-5.16.3/lib/abbrev.pl +--- perl-5.16.3-orig/lib/abbrev.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/abbrev.pl 2016-08-18 10:07:06.401442446 +0200 +@@ -0,0 +1,43 @@ ++;# Usage: ++;# %foo = (); ++;# &abbrev(*foo,LIST); ++;# ... ++;# $long = $foo{$short}; ++ ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Text::Abbrev ++# ++ ++package abbrev; ++ ++sub main'abbrev { ++ local(*domain) = @_; ++ shift(@_); ++ @cmp = @_; ++ local($[) = 0; ++ foreach $name (@_) { ++ @extra = split(//,$name); ++ $abbrev = shift(@extra); ++ $len = 1; ++ foreach $cmp (@cmp) { ++ next if $cmp eq $name; ++ while (@extra && substr($cmp,0,$len) eq $abbrev) { ++ $abbrev .= shift(@extra); ++ ++$len; ++ } ++ } ++ $domain{$abbrev} = $name; ++ while ($#extra >= 0) { ++ $abbrev .= shift(@extra); ++ $domain{$abbrev} = $name; ++ } ++ } ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/assert.pl perl-5.16.3/lib/assert.pl +--- perl-5.16.3-orig/lib/assert.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/assert.pl 2016-08-18 10:07:06.409442411 +0200 +@@ -0,0 +1,55 @@ ++# assert.pl ++# tchrist@convex.com (Tom Christiansen) ++# ++# Usage: ++# ++# &assert('@x > @y'); ++# &assert('$var > 10', $var, $othervar, @various_info); ++# ++# That is, if the first expression evals false, we blow up. The ++# rest of the args, if any, are nice to know because they will ++# be printed out by &panic, which is just the stack-backtrace ++# routine shamelessly borrowed from the perl debugger. ++ ++sub assert { ++ &panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[]; ++} ++ ++sub panic { ++ package DB; ++ ++ select(STDERR); ++ ++ print "\npanic: @_\n"; ++ ++ exit 1 if $] <= 4.003; # caller broken ++ ++ # stack traceback gratefully borrowed from perl debugger ++ ++ local $_; ++ my $i; ++ my ($p,$f,$l,$s,$h,$a,@a,@frames); ++ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { ++ @a = @args; ++ for (@a) { ++ if (/^StB\000/ && length($_) == length($_main{'_main'})) { ++ $_ = sprintf("%s",$_); ++ } ++ else { ++ s/'/\\'/g; ++ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; ++ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; ++ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; ++ } ++ } ++ $w = $w ? '@ = ' : '$ = '; ++ $a = $h ? '(' . join(', ', @a) . ')' : ''; ++ push(@frames, "$w&$s$a from file $f line $l\n"); ++ } ++ for ($i=0; $i <= $#frames; $i++) { ++ print $frames[$i]; ++ } ++ exit 1; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/bigfloat.pl perl-5.16.3/lib/bigfloat.pl +--- perl-5.16.3-orig/lib/bigfloat.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/bigfloat.pl 2016-08-18 10:07:06.418442371 +0200 +@@ -0,0 +1,254 @@ ++package bigfloat; ++require "bigint.pl"; ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Math::BigFloat ++# ++# Arbitrary length float math package ++# ++# by Mark Biggar ++# ++# number format ++# canonical strings have the form /[+-]\d+E[+-]\d+/ ++# Input values can have embedded whitespace ++# Error returns ++# 'NaN' An input parameter was "Not a Number" or ++# divide by zero or sqrt of negative number ++# Division is computed to ++# max($div_scale,length(dividend)+length(divisor)) ++# digits by default. ++# Also used for default sqrt scale ++ ++$div_scale = 40; ++ ++# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. ++ ++$rnd_mode = 'even'; ++ ++# bigfloat routines ++# ++# fadd(NSTR, NSTR) return NSTR addition ++# fsub(NSTR, NSTR) return NSTR subtraction ++# fmul(NSTR, NSTR) return NSTR multiplication ++# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places ++# fneg(NSTR) return NSTR negation ++# fabs(NSTR) return NSTR absolute value ++# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 ++# fround(NSTR, SCALE) return NSTR round to SCALE digits ++# ffround(NSTR, SCALE) return NSTR round at SCALEth place ++# fnorm(NSTR) return (NSTR) normalize ++# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places ++ ++# Convert a number to canonical string form. ++# Takes something that looks like a number and converts it to ++# the form /^[+-]\d+E[+-]\d+$/. ++sub main'fnorm { #(string) return fnum_str ++ local($_) = @_; ++ s/\s+//g; # strip white space ++ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ ++ && ($2 ne '' || defined($4))) { ++ my $x = defined($4) ? $4 : ''; ++ &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6)); ++ } else { ++ 'NaN'; ++ } ++} ++ ++# normalize number -- for internal use ++sub norm { #(mantissa, exponent) return fnum_str ++ local($_, $exp) = @_; ++ if ($_ eq 'NaN') { ++ 'NaN'; ++ } else { ++ s/^([+-])0+/$1/; # strip leading zeros ++ if (length($_) == 1) { ++ '+0E+0'; ++ } else { ++ $exp += length($1) if (s/(0+)$//); # strip trailing zeros ++ sprintf("%sE%+ld", $_, $exp); ++ } ++ } ++} ++ ++# negation ++sub main'fneg { #(fnum_str) return fnum_str ++ local($_) = &'fnorm($_[$[]); ++ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign ++ if ( ord("\t") == 9 ) { # ascii ++ s/^H/N/; ++ } ++ else { # ebcdic character set ++ s/\373/N/; ++ } ++ $_; ++} ++ ++# absolute value ++sub main'fabs { #(fnum_str) return fnum_str ++ local($_) = &'fnorm($_[$[]); ++ s/^-/+/; # mash sign ++ $_; ++} ++ ++# multiplication ++sub main'fmul { #(fnum_str, fnum_str) return fnum_str ++ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1])); ++ if ($x eq 'NaN' || $y eq 'NaN') { ++ 'NaN'; ++ } else { ++ local($xm,$xe) = split('E',$x); ++ local($ym,$ye) = split('E',$y); ++ &norm(&'bmul($xm,$ym),$xe+$ye); ++ } ++} ++ ++# addition ++sub main'fadd { #(fnum_str, fnum_str) return fnum_str ++ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1])); ++ if ($x eq 'NaN' || $y eq 'NaN') { ++ 'NaN'; ++ } else { ++ local($xm,$xe) = split('E',$x); ++ local($ym,$ye) = split('E',$y); ++ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); ++ &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye); ++ } ++} ++ ++# subtraction ++sub main'fsub { #(fnum_str, fnum_str) return fnum_str ++ &'fadd($_[$[],&'fneg($_[$[+1])); ++} ++ ++# division ++# args are dividend, divisor, scale (optional) ++# result has at most max(scale, length(dividend), length(divisor)) digits ++sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str ++{ ++ local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]); ++ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { ++ 'NaN'; ++ } else { ++ local($xm,$xe) = split('E',$x); ++ local($ym,$ye) = split('E',$y); ++ $scale = $div_scale if (!$scale); ++ $scale = length($xm)-1 if (length($xm)-1 > $scale); ++ $scale = length($ym)-1 if (length($ym)-1 > $scale); ++ $scale = $scale + length($ym) - length($xm); ++ &norm(&round(&'bdiv($xm.('0' x $scale),$ym),&'babs($ym)), ++ $xe-$ye-$scale); ++ } ++} ++ ++# round int $q based on fraction $r/$base using $rnd_mode ++sub round { #(int_str, int_str, int_str) return int_str ++ local($q,$r,$base) = @_; ++ if ($q eq 'NaN' || $r eq 'NaN') { ++ 'NaN'; ++ } elsif ($rnd_mode eq 'trunc') { ++ $q; # just truncate ++ } else { ++ local($cmp) = &'bcmp(&'bmul($r,'+2'),$base); ++ if ( $cmp < 0 || ++ ($cmp == 0 && ++ ( $rnd_mode eq 'zero' || ++ ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) || ++ ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) || ++ ($rnd_mode eq 'even' && $q =~ /[24680]$/) || ++ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { ++ $q; # round down ++ } else { ++ &'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1')); ++ # round up ++ } ++ } ++} ++ ++# round the mantissa of $x to $scale digits ++sub main'fround { #(fnum_str, scale) return fnum_str ++ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]); ++ if ($x eq 'NaN' || $scale <= 0) { ++ $x; ++ } else { ++ local($xm,$xe) = split('E',$x); ++ if (length($xm)-1 <= $scale) { ++ $x; ++ } else { ++ &norm(&round(substr($xm,$[,$scale+1), ++ "+0".substr($xm,$[+$scale+1,1),"+10"), ++ $xe+length($xm)-$scale-1); ++ } ++ } ++} ++ ++# round $x at the 10 to the $scale digit place ++sub main'ffround { #(fnum_str, scale) return fnum_str ++ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]); ++ if ($x eq 'NaN') { ++ 'NaN'; ++ } else { ++ local($xm,$xe) = split('E',$x); ++ if ($xe >= $scale) { ++ $x; ++ } else { ++ $xe = length($xm)+$xe-$scale; ++ if ($xe < 1) { ++ '+0E+0'; ++ } elsif ($xe == 1) { ++ # The first substr preserves the sign, which means that ++ # we'll pass a non-normalized "-0" to &round when rounding ++ # -0.006 (for example), purely so that &round won't lose ++ # the sign. ++ &norm(&round(substr($xm,$[,1).'0', ++ "+0".substr($xm,$[+1,1),"+10"), $scale); ++ } else { ++ &norm(&round(substr($xm,$[,$xe), ++ "+0".substr($xm,$[+$xe,1),"+10"), $scale); ++ } ++ } ++ } ++} ++ ++# compare 2 values returns one of undef, <0, =0, >0 ++# returns undef if either or both input value are not numbers ++sub main'fcmp #(fnum_str, fnum_str) return cond_code ++{ ++ local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1])); ++ if ($x eq "NaN" || $y eq "NaN") { ++ undef; ++ } else { ++ ord($y) <=> ord($x) ++ || ++ ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), ++ (($xe <=> $ye) * (substr($x,$[,1).'1') ++ || &bigint'cmp($xm,$ym)) ++ ); ++ } ++} ++ ++# square root by Newtons method. ++sub main'fsqrt { #(fnum_str[, scale]) return fnum_str ++ local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]); ++ if ($x eq 'NaN' || $x =~ /^-/) { ++ 'NaN'; ++ } elsif ($x eq '+0E+0') { ++ '+0E+0'; ++ } else { ++ local($xm, $xe) = split('E',$x); ++ $scale = $div_scale if (!$scale); ++ $scale = length($xm)-1 if ($scale < length($xm)-1); ++ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); ++ while ($gs < 2*$scale) { ++ $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5"); ++ $gs *= 2; ++ } ++ &'fround($guess, $scale); ++ } ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/bigint.pl perl-5.16.3/lib/bigint.pl +--- perl-5.16.3-orig/lib/bigint.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/bigint.pl 2016-08-18 10:07:06.431442314 +0200 +@@ -0,0 +1,320 @@ ++package bigint; ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Math::BigInt ++# ++# arbitrary size integer math package ++# ++# by Mark Biggar ++# ++# Canonical Big integer value are strings of the form ++# /^[+-]\d+$/ with leading zeros suppressed ++# Input values to these routines may be strings of the form ++# /^\s*[+-]?[\d\s]+$/. ++# Examples: ++# '+0' canonical zero value ++# ' -123 123 123' canonical value '-123123123' ++# '1 23 456 7890' canonical value '+1234567890' ++# Output values always in canonical form ++# ++# Actual math is done in an internal format consisting of an array ++# whose first element is the sign (/^[+-]$/) and whose remaining ++# elements are base 100000 digits with the least significant digit first. ++# The string 'NaN' is used to represent the result when input arguments ++# are not numbers, as well as the result of dividing by zero ++# ++# routines provided are: ++# ++# bneg(BINT) return BINT negation ++# babs(BINT) return BINT absolute value ++# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) ++# badd(BINT,BINT) return BINT addition ++# bsub(BINT,BINT) return BINT subtraction ++# bmul(BINT,BINT) return BINT multiplication ++# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar ++# bmod(BINT,BINT) return BINT modulus ++# bgcd(BINT,BINT) return BINT greatest common divisor ++# bnorm(BINT) return BINT normalization ++# ++ ++# overcome a floating point problem on certain osnames (posix-bc, os390) ++BEGIN { ++ my $x = 100000.0; ++ my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0; ++} ++ ++$zero = 0; ++ ++ ++# normalize string form of number. Strip leading zeros. Strip any ++# white space and add a sign, if missing. ++# Strings that are not numbers result the value 'NaN'. ++ ++sub main'bnorm { #(num_str) return num_str ++ local($_) = @_; ++ s/\s+//g; # strip white space ++ if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number ++ substr($_,$[,0) = '+' unless $1; # Add missing sign ++ s/^-0/+0/; ++ $_; ++ } else { ++ 'NaN'; ++ } ++} ++ ++# Convert a number from string format to internal base 100000 format. ++# Assumes normalized value as input. ++sub internal { #(num_str) return int_num_array ++ local($d) = @_; ++ ($is,$il) = (substr($d,$[,1),length($d)-2); ++ substr($d,$[,1) = ''; ++ ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); ++} ++ ++# Convert a number from internal base 100000 format to string format. ++# This routine scribbles all over input array. ++sub external { #(int_num_array) return num_str ++ $es = shift; ++ grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad ++ &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize ++} ++ ++# Negate input value. ++sub main'bneg { #(num_str) return num_str ++ local($_) = &'bnorm(@_); ++ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; ++ s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC ++ $_; ++} ++ ++# Returns the absolute value of the input. ++sub main'babs { #(num_str) return num_str ++ &abs(&'bnorm(@_)); ++} ++ ++sub abs { # post-normalized abs for internal use ++ local($_) = @_; ++ s/^-/+/; ++ $_; ++} ++ ++# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) ++sub main'bcmp { #(num_str, num_str) return cond_code ++ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); ++ if ($x eq 'NaN') { ++ undef; ++ } elsif ($y eq 'NaN') { ++ undef; ++ } else { ++ &cmp($x,$y); ++ } ++} ++ ++sub cmp { # post-normalized compare for internal use ++ local($cx, $cy) = @_; ++ return 0 if ($cx eq $cy); ++ ++ local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1)); ++ local($ld); ++ ++ if ($sx eq '+') { ++ return 1 if ($sy eq '-' || $cy eq '+0'); ++ $ld = length($cx) - length($cy); ++ return $ld if ($ld); ++ return $cx cmp $cy; ++ } else { # $sx eq '-' ++ return -1 if ($sy eq '+'); ++ $ld = length($cy) - length($cx); ++ return $ld if ($ld); ++ return $cy cmp $cx; ++ } ++ ++} ++ ++sub main'badd { #(num_str, num_str) return num_str ++ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); ++ if ($x eq 'NaN') { ++ 'NaN'; ++ } elsif ($y eq 'NaN') { ++ 'NaN'; ++ } else { ++ @x = &internal($x); # convert to internal form ++ @y = &internal($y); ++ local($sx, $sy) = (shift @x, shift @y); # get signs ++ if ($sx eq $sy) { ++ &external($sx, &add(*x, *y)); # if same sign add ++ } else { ++ ($x, $y) = (&abs($x),&abs($y)); # make abs ++ if (&cmp($y,$x) > 0) { ++ &external($sy, &sub(*y, *x)); ++ } else { ++ &external($sx, &sub(*x, *y)); ++ } ++ } ++ } ++} ++ ++sub main'bsub { #(num_str, num_str) return num_str ++ &'badd($_[$[],&'bneg($_[$[+1])); ++} ++ ++# GCD -- Euclids algorithm Knuth Vol 2 pg 296 ++sub main'bgcd { #(num_str, num_str) return num_str ++ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1])); ++ if ($x eq 'NaN' || $y eq 'NaN') { ++ 'NaN'; ++ } else { ++ ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; ++ $x; ++ } ++} ++ ++# routine to add two base 1e5 numbers ++# stolen from Knuth Vol 2 Algorithm A pg 231 ++# there are separate routines to add and sub as per Kunth pg 233 ++sub add { #(int_num_array, int_num_array) return int_num_array ++ local(*x, *y) = @_; ++ $car = 0; ++ for $x (@x) { ++ last unless @y || $car; ++ $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; ++ } ++ for $y (@y) { ++ last unless $car; ++ $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0; ++ } ++ (@x, @y, $car); ++} ++ ++# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y ++sub sub { #(int_num_array, int_num_array) return int_num_array ++ local(*sx, *sy) = @_; ++ $bar = 0; ++ for $sx (@sx) { ++ last unless @y || $bar; ++ $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); ++ } ++ @sx; ++} ++ ++# multiply two numbers -- stolen from Knuth Vol 2 pg 233 ++sub main'bmul { #(num_str, num_str) return num_str ++ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1])); ++ if ($x eq 'NaN') { ++ 'NaN'; ++ } elsif ($y eq 'NaN') { ++ 'NaN'; ++ } else { ++ @x = &internal($x); ++ @y = &internal($y); ++ local($signr) = (shift @x ne shift @y) ? '-' : '+'; ++ @prod = (); ++ for $x (@x) { ++ ($car, $cty) = (0, $[); ++ for $y (@y) { ++ $prod = $x * $y + $prod[$cty] + $car; ++ if ($use_mult) { ++ $prod[$cty++] = ++ $prod - ($car = int($prod * 1e-5)) * 1e5; ++ } ++ else { ++ $prod[$cty++] = ++ $prod - ($car = int($prod / 1e5)) * 1e5; ++ } ++ } ++ $prod[$cty] += $car if $car; ++ $x = shift @prod; ++ } ++ &external($signr, @x, @prod); ++ } ++} ++ ++# modulus ++sub main'bmod { #(num_str, num_str) return num_str ++ (&'bdiv(@_))[$[+1]; ++} ++ ++sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str ++ local (*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1])); ++ return wantarray ? ('NaN','NaN') : 'NaN' ++ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); ++ return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); ++ @x = &internal($x); @y = &internal($y); ++ $srem = $y[$[]; ++ $sr = (shift @x ne shift @y) ? '-' : '+'; ++ $car = $bar = $prd = 0; ++ if (($dd = int(1e5/($y[$#y]+1))) != 1) { ++ for $x (@x) { ++ $x = $x * $dd + $car; ++ if ($use_mult) { ++ $x -= ($car = int($x * 1e-5)) * 1e5; ++ } ++ else { ++ $x -= ($car = int($x / 1e5)) * 1e5; ++ } ++ } ++ push(@x, $car); $car = 0; ++ for $y (@y) { ++ $y = $y * $dd + $car; ++ if ($use_mult) { ++ $y -= ($car = int($y * 1e-5)) * 1e5; ++ } ++ else { ++ $y -= ($car = int($y / 1e5)) * 1e5; ++ } ++ } ++ } ++ else { ++ push(@x, 0); ++ } ++ @q = (); ($v2,$v1) = @y[-2,-1]; ++ while ($#x > $#y) { ++ ($u2,$u1,$u0) = @x[-3..-1]; ++ $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); ++ --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); ++ if ($q) { ++ ($car, $bar) = (0,0); ++ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { ++ $prd = $q * $y[$y] + $car; ++ if ($use_mult) { ++ $prd -= ($car = int($prd * 1e-5)) * 1e5; ++ } ++ else { ++ $prd -= ($car = int($prd / 1e5)) * 1e5; ++ } ++ $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); ++ } ++ if ($x[$#x] < $car + $bar) { ++ $car = 0; --$q; ++ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { ++ $x[$x] -= 1e5 ++ if ($car = (($x[$x] += $y[$y] + $car) > 1e5)); ++ } ++ } ++ } ++ pop(@x); unshift(@q, $q); ++ } ++ if (wantarray) { ++ @d = (); ++ if ($dd != 1) { ++ $car = 0; ++ for $x (reverse @x) { ++ $prd = $car * 1e5 + $x; ++ $car = $prd - ($tmp = int($prd / $dd)) * $dd; ++ unshift(@d, $tmp); ++ } ++ } ++ else { ++ @d = @x; ++ } ++ (&external($sr, @q), &external($srem, @d, $zero)); ++ } else { ++ &external($sr, @q); ++ } ++} ++1; +diff -ENwbur perl-5.16.3-orig/lib/bigrat.pl perl-5.16.3/lib/bigrat.pl +--- perl-5.16.3-orig/lib/bigrat.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/bigrat.pl 2016-08-18 10:07:06.441442270 +0200 +@@ -0,0 +1,155 @@ ++package bigrat; ++require "bigint.pl"; ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Arbitrary size rational math package ++# ++# by Mark Biggar ++# ++# Input values to these routines consist of strings of the form ++# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|. ++# Examples: ++# "+0/1" canonical zero value ++# "3" canonical value "+3/1" ++# " -123/123 123" canonical value "-1/1001" ++# "123 456/7890" canonical value "+20576/1315" ++# Output values always include a sign and no leading zeros or ++# white space. ++# This package makes use of the bigint package. ++# The string 'NaN' is used to represent the result when input arguments ++# that are not numbers, as well as the result of dividing by zero and ++# the sqrt of a negative number. ++# Extreamly naive algorthims are used. ++# ++# Routines provided are: ++# ++# rneg(RAT) return RAT negation ++# rabs(RAT) return RAT absolute value ++# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0) ++# radd(RAT,RAT) return RAT addition ++# rsub(RAT,RAT) return RAT subtraction ++# rmul(RAT,RAT) return RAT multiplication ++# rdiv(RAT,RAT) return RAT division ++# rmod(RAT) return (RAT,RAT) integer and fractional parts ++# rnorm(RAT) return RAT normalization ++# rsqrt(RAT, cycles) return RAT square root ++ ++# Convert a number to the canonical string form m|^[+-]\d+/\d+|. ++sub main'rnorm { #(string) return rat_num ++ local($_) = @_; ++ s/\s+//g; ++ if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) { ++ &norm($1, $3 ? $3 : '+1'); ++ } else { ++ 'NaN'; ++ } ++} ++ ++# Normalize by reducing to lowest terms ++sub norm { #(bint, bint) return rat_num ++ local($num,$dom) = @_; ++ if ($num eq 'NaN') { ++ 'NaN'; ++ } elsif ($dom eq 'NaN') { ++ 'NaN'; ++ } elsif ($dom =~ /^[+-]?0+$/) { ++ 'NaN'; ++ } else { ++ local($gcd) = &'bgcd($num,$dom); ++ $gcd =~ s/^-/+/; ++ if ($gcd ne '+1') { ++ $num = &'bdiv($num,$gcd); ++ $dom = &'bdiv($dom,$gcd); ++ } else { ++ $num = &'bnorm($num); ++ $dom = &'bnorm($dom); ++ } ++ substr($dom,$[,1) = ''; ++ "$num/$dom"; ++ } ++} ++ ++# negation ++sub main'rneg { #(rat_num) return rat_num ++ local($_) = &'rnorm(@_); ++ tr/-+/+-/ if ($_ ne '+0/1'); ++ $_; ++} ++ ++# absolute value ++sub main'rabs { #(rat_num) return $rat_num ++ local($_) = &'rnorm(@_); ++ substr($_,$[,1) = '+' unless $_ eq 'NaN'; ++ $_; ++} ++ ++# multipication ++sub main'rmul { #(rat_num, rat_num) return rat_num ++ local($xn,$xd) = split('/',&'rnorm($_[$[])); ++ local($yn,$yd) = split('/',&'rnorm($_[$[+1])); ++ &norm(&'bmul($xn,$yn),&'bmul($xd,$yd)); ++} ++ ++# division ++sub main'rdiv { #(rat_num, rat_num) return rat_num ++ local($xn,$xd) = split('/',&'rnorm($_[$[])); ++ local($yn,$yd) = split('/',&'rnorm($_[$[+1])); ++ &norm(&'bmul($xn,$yd),&'bmul($xd,$yn)); ++} ++ ++# addition ++sub main'radd { #(rat_num, rat_num) return rat_num ++ local($xn,$xd) = split('/',&'rnorm($_[$[])); ++ local($yn,$yd) = split('/',&'rnorm($_[$[+1])); ++ &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); ++} ++ ++# subtraction ++sub main'rsub { #(rat_num, rat_num) return rat_num ++ local($xn,$xd) = split('/',&'rnorm($_[$[])); ++ local($yn,$yd) = split('/',&'rnorm($_[$[+1])); ++ &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); ++} ++ ++# comparison ++sub main'rcmp { #(rat_num, rat_num) return cond_code ++ local($xn,$xd) = split('/',&'rnorm($_[$[])); ++ local($yn,$yd) = split('/',&'rnorm($_[$[+1])); ++ &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd)); ++} ++ ++# int and frac parts ++sub main'rmod { #(rat_num) return (rat_num,rat_num) ++ local($xn,$xd) = split('/',&'rnorm(@_)); ++ local($i,$f) = &'bdiv($xn,$xd); ++ if (wantarray) { ++ ("$i/1", "$f/$xd"); ++ } else { ++ "$i/1"; ++ } ++} ++ ++# square root by Newtons method. ++# cycles specifies the number of iterations default: 5 ++sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str ++ local($x, $scale) = (&'rnorm($_[$[]), $_[$[+1]); ++ if ($x eq 'NaN') { ++ 'NaN'; ++ } elsif ($x =~ /^-/) { ++ 'NaN'; ++ } else { ++ local($gscale, $guess) = (0, '+1/1'); ++ $scale = 5 if (!$scale); ++ while ($gscale++ < $scale) { ++ $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2"); ++ } ++ "$guess"; # quotes necessary due to perl bug ++ } ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/cacheout.pl perl-5.16.3/lib/cacheout.pl +--- perl-5.16.3-orig/lib/cacheout.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/cacheout.pl 2016-08-18 10:07:06.452442221 +0200 +@@ -0,0 +1,55 @@ ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: FileCache ++ ++# Open in their package. ++ ++sub cacheout'open { ++ open($_[0], $_[1]); ++} ++ ++# Close as well ++ ++sub cacheout'close { ++ close($_[0]); ++} ++ ++# But only this sub name is visible to them. ++ ++sub cacheout { ++ package cacheout; ++ ++ ($file) = @_; ++ if (!$isopen{$file}) { ++ if (++$numopen > $maxopen) { ++ local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); ++ splice(@lru, $maxopen / 3); ++ $numopen -= @lru; ++ for (@lru) { &close($_); delete $isopen{$_}; } ++ } ++ &open($file, ($saw{$file}++ ? '>>' : '>') . $file) ++ || die "Can't create $file: $!\n"; ++ } ++ $isopen{$file} = ++$seq; ++} ++ ++package cacheout; ++ ++$seq = 0; ++$numopen = 0; ++ ++if (open(PARAM,'/usr/include/sys/param.h')) { ++ local($_, $.); ++ while () { ++ $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; ++ } ++ close PARAM; ++} ++$maxopen = 16 unless $maxopen; ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/complete.pl perl-5.16.3/lib/complete.pl +--- perl-5.16.3-orig/lib/complete.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/complete.pl 2016-08-18 10:07:06.460442186 +0200 +@@ -0,0 +1,120 @@ ++;# ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Term::Complete ++# ++;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 ++;# ++;# Author: Wayne Thompson ++;# ++;# Description: ++;# This routine provides word completion. ++;# (TAB) attempts word completion. ++;# (^D) prints completion list. ++;# (These may be changed by setting $Complete'complete, etc.) ++;# ++;# Diagnostics: ++;# Bell when word completion fails. ++;# ++;# Dependencies: ++;# The tty driver is put into raw mode. ++;# ++;# Bugs: ++;# ++;# Usage: ++;# $input = &Complete('prompt_string', *completion_list); ++;# or ++;# $input = &Complete('prompt_string', @completion_list); ++;# ++ ++CONFIG: { ++ package Complete; ++ ++ $complete = "\004"; ++ $kill = "\025"; ++ $erase1 = "\177"; ++ $erase2 = "\010"; ++} ++ ++sub Complete { ++ package Complete; ++ ++ local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); ++ if ($_[1] =~ /^StB\0/) { ++ ($prompt, *_) = @_; ++ } ++ else { ++ $prompt = shift(@_); ++ } ++ @cmp_lst = sort(@_); ++ ++ system('stty raw -echo'); ++ LOOP: { ++ print($prompt, $return); ++ while (($_ = getc(STDIN)) ne "\r") { ++ CASE: { ++ # (TAB) attempt completion ++ $_ eq "\t" && do { ++ @match = grep(/^$return/, @cmp_lst); ++ $l = length($test = shift(@match)); ++ unless ($#match < 0) { ++ foreach $cmp (@match) { ++ until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { ++ $l--; ++ } ++ } ++ print("\a"); ++ } ++ print($test = substr($test, $r, $l - $r)); ++ $r = length($return .= $test); ++ last CASE; ++ }; ++ ++ # (^D) completion list ++ $_ eq $complete && do { ++ print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); ++ redo LOOP; ++ }; ++ ++ # (^U) kill ++ $_ eq $kill && do { ++ if ($r) { ++ undef $r; ++ undef $return; ++ print("\r\n"); ++ redo LOOP; ++ } ++ last CASE; ++ }; ++ ++ # (DEL) || (BS) erase ++ ($_ eq $erase1 || $_ eq $erase2) && do { ++ if($r) { ++ print("\b \b"); ++ chop($return); ++ $r--; ++ } ++ last CASE; ++ }; ++ ++ # printable char ++ ord >= 32 && do { ++ $return .= $_; ++ $r++; ++ print; ++ last CASE; ++ }; ++ } ++ } ++ } ++ system('stty -raw echo'); ++ print("\n"); ++ $return; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/ctime.pl perl-5.16.3/lib/ctime.pl +--- perl-5.16.3-orig/lib/ctime.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/ctime.pl 2016-08-18 10:07:06.471442137 +0200 +@@ -0,0 +1,59 @@ ++;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function. ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: the POSIX ctime function ++;# ++;# Waldemar Kebsch, Federal Republic of Germany, November 1988 ++;# kebsch.pad@nixpbe.UUCP ++;# Modified March 1990, Feb 1991 to properly handle timezones ++;# $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $ ++;# Marion Hakanson (hakanson@cse.ogi.edu) ++;# Oregon Graduate Institute of Science and Technology ++;# ++;# usage: ++;# ++;# #include # see the -P and -I option in perl.man ++;# $Date = &ctime(time); ++ ++CONFIG: { ++ package ctime; ++ ++ @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); ++ @MoY = ('Jan','Feb','Mar','Apr','May','Jun', ++ 'Jul','Aug','Sep','Oct','Nov','Dec'); ++} ++ ++sub ctime { ++ package ctime; ++ ++ local($time) = @_; ++ local($[) = 0; ++ local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst); ++ ++ # Determine what time zone is in effect. ++ # Use GMT if TZ is defined as null, local time if TZ undefined. ++ # There's no portable way to find the system default timezone. ++ ++ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''; ++ ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = ++ ($TZ eq 'GMT') ? gmtime($time) : localtime($time); ++ ++ # Hack to deal with 'PST8PDT' format of TZ ++ # Note that this can't deal with all the esoteric forms, but it ++ # does recognize the most common: [:]STDoff[DST[off][,rule]] ++ ++ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){ ++ $TZ = $isdst ? $4 : $1; ++ } ++ $TZ .= ' ' unless $TZ eq ''; ++ ++ $year += 1900; ++ sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n", ++ $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year); ++} ++1; +diff -ENwbur perl-5.16.3-orig/lib/dotsh.pl perl-5.16.3/lib/dotsh.pl +--- perl-5.16.3-orig/lib/dotsh.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/dotsh.pl 2016-08-18 10:07:06.481442093 +0200 +@@ -0,0 +1,74 @@ ++# ++# @(#)dotsh.pl 03/19/94 ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# ++# Author: Charles Collins ++# ++# Description: ++# This routine takes a shell script and 'dots' it into the current perl ++# environment. This makes it possible to use existing system scripts ++# to alter environment variables on the fly. ++# ++# Usage: ++# &dotsh ('ShellScript', 'DependentVariable(s)'); ++# ++# where ++# ++# 'ShellScript' is the full name of the shell script to be dotted ++# ++# 'DependentVariable(s)' is an optional list of shell variables in the ++# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is ++# dependent upon. These variables MUST be defined using shell syntax. ++# ++# Example: ++# &dotsh ('/foo/bar', 'arg1'); ++# &dotsh ('/foo/bar'); ++# &dotsh ('/foo/bar arg1 ... argN'); ++# ++sub dotsh { ++ local(@sh) = @_; ++ local($tmp,$key,$shell,$command,$args,$vars) = ''; ++ local(*dotsh); ++ undef *dotsh; ++ $dotsh = shift(@sh); ++ @dotsh = split (/\s/, $dotsh); ++ $command = shift (@dotsh); ++ $args = join (" ", @dotsh); ++ $vars = join ("\n", @sh); ++ open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; ++ chop($_ = <_SH_ENV>); ++ $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); ++ close (_SH_ENV); ++ if (!$shell) { ++ if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/bash$|\/csh$/) { ++ $shell = "$ENV{'SHELL'} -c"; ++ } else { ++ print "SHELL not recognized!\nUsing /bin/sh...\n"; ++ $shell = "/bin/sh -c"; ++ } ++ } ++ if (length($vars) > 0) { ++ open (_SH_ENV, "$shell \"$vars && . $command $args && set \" |") || die; ++ } else { ++ open (_SH_ENV, "$shell \". $command $args && set \" |") || die; ++ } ++ ++ while (<_SH_ENV>) { ++ chop; ++ m/^([^=]*)=(.*)/s; ++ $ENV{$1} = $2; ++ } ++ close (_SH_ENV); ++ ++ foreach $key (keys(%ENV)) { ++ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; ++ } ++ eval $tmp; ++} ++1; +diff -ENwbur perl-5.16.3-orig/lib/exceptions.pl perl-5.16.3/lib/exceptions.pl +--- perl-5.16.3-orig/lib/exceptions.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/exceptions.pl 2016-08-18 10:07:06.491442049 +0200 +@@ -0,0 +1,61 @@ ++# exceptions.pl ++# tchrist@convex.com ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# ++# Here's a little code I use for exception handling. It's really just ++# glorfied eval/die. The way to use use it is when you might otherwise ++# exit, use &throw to raise an exception. The first enclosing &catch ++# handler looks at the exception and decides whether it can catch this kind ++# (catch takes a list of regexps to catch), and if so, it returns the one it ++# caught. If it *can't* catch it, then it will reraise the exception ++# for someone else to possibly see, or to die otherwise. ++# ++# I use oddly named variables in order to make darn sure I don't conflict ++# with my caller. I also hide in my own package, and eval the code in his. ++# ++# The EXCEPTION: prefix is so you can tell whether it's a user-raised ++# exception or a perl-raised one (eval error). ++# ++# --tom ++# ++# examples: ++# if (&catch('/$user_input/', 'regexp', 'syntax error') { ++# warn "oops try again"; ++# redo; ++# } ++# ++# if ($error = &catch('&subroutine()')) { # catches anything ++# ++# &throw('bad input') if /^$/; ++ ++sub catch { ++ package exception; ++ local($__code__, @__exceptions__) = @_; ++ local($__package__) = caller; ++ local($__exception__); ++ ++ eval "package $__package__; $__code__"; ++ if ($__exception__ = &'thrown) { ++ for (@__exceptions__) { ++ return $__exception__ if /$__exception__/; ++ } ++ &'throw($__exception__); ++ } ++} ++ ++sub throw { ++ local($exception) = @_; ++ die "EXCEPTION: $exception\n"; ++} ++ ++sub thrown { ++ $@ =~ /^(EXCEPTION: )+(.+)/ && $2; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/fastcwd.pl perl-5.16.3/lib/fastcwd.pl +--- perl-5.16.3-orig/lib/fastcwd.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/fastcwd.pl 2016-08-18 10:07:06.501442005 +0200 +@@ -0,0 +1,43 @@ ++# By John Bazik ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Cwd ++# ++# Usage: $cwd = &fastcwd; ++# ++# This is a faster version of getcwd. It's also more dangerous because ++# you might chdir out of a directory that you can't chdir back into. ++ ++sub fastcwd { ++ local($odev, $oino, $cdev, $cino, $tdev, $tino); ++ local(@path, $path); ++ local(*DIR); ++ ++ ($cdev, $cino) = stat('.'); ++ for (;;) { ++ ($odev, $oino) = ($cdev, $cino); ++ chdir('..'); ++ ($cdev, $cino) = stat('.'); ++ last if $odev == $cdev && $oino == $cino; ++ opendir(DIR, '.'); ++ for (;;) { ++ $_ = readdir(DIR); ++ next if $_ eq '.'; ++ next if $_ eq '..'; ++ ++ last unless $_; ++ ($tdev, $tino) = lstat($_); ++ last unless $tdev != $odev || $tino != $oino; ++ } ++ closedir(DIR); ++ unshift(@path, $_); ++ } ++ chdir($path = '/' . join('/', @path)); ++ $path; ++} ++1; +diff -ENwbur perl-5.16.3-orig/lib/find.pl perl-5.16.3/lib/find.pl +--- perl-5.16.3-orig/lib/find.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/find.pl 2016-08-18 10:07:06.510441965 +0200 +@@ -0,0 +1,47 @@ ++# Usage: ++# require "find.pl"; ++# ++# &find('/foo','/bar'); ++# ++# sub wanted { ... } ++# where wanted does whatever you want. $dir contains the ++# current directory name, and $_ the current filename within ++# that directory. $name contains "$dir/$_". You are cd'ed ++# to $dir when the function is called. The function may ++# set $prune to prune the tree. ++# ++# This library is primarily for find2perl, which, when fed ++# ++# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune ++# ++# spits out something like this ++# ++# sub wanted { ++# /^\.nfs.*$/ && ++# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && ++# int(-M _) > 7 && ++# unlink($_) ++# || ++# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && ++# $dev < 0 && ++# ($prune = 1); ++# } ++# ++# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. ++ ++use File::Find (); ++ ++*name = *File::Find::name; ++*prune = *File::Find::prune; ++*dir = *File::Find::dir; ++*topdir = *File::Find::topdir; ++*topdev = *File::Find::topdev; ++*topino = *File::Find::topino; ++*topmode = *File::Find::topmode; ++*topnlink = *File::Find::topnlink; ++ ++sub find { ++ &File::Find::find(\&wanted, @_); ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/finddepth.pl perl-5.16.3/lib/finddepth.pl +--- perl-5.16.3-orig/lib/finddepth.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/finddepth.pl 2016-08-18 10:07:06.520441921 +0200 +@@ -0,0 +1,46 @@ ++# Usage: ++# require "finddepth.pl"; ++# ++# &finddepth('/foo','/bar'); ++# ++# sub wanted { ... } ++# where wanted does whatever you want. $dir contains the ++# current directory name, and $_ the current filename within ++# that directory. $name contains "$dir/$_". You are cd'ed ++# to $dir when the function is called. The function may ++# set $prune to prune the tree. ++# ++# This library is primarily for find2perl, which, when fed ++# ++# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune ++# ++# spits out something like this ++# ++# sub wanted { ++# /^\.nfs.*$/ && ++# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && ++# int(-M _) > 7 && ++# unlink($_) ++# || ++# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && ++# $dev < 0 && ++# ($prune = 1); ++# } ++ ++ ++use File::Find (); ++ ++*name = *File::Find::name; ++*prune = *File::Find::prune; ++*dir = *File::Find::dir; ++*topdir = *File::Find::topdir; ++*topdev = *File::Find::topdev; ++*topino = *File::Find::topino; ++*topmode = *File::Find::topmode; ++*topnlink = *File::Find::topnlink; ++ ++sub finddepth { ++ &File::Find::finddepth(\&wanted, @_); ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/flush.pl perl-5.16.3/lib/flush.pl +--- perl-5.16.3-orig/lib/flush.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/flush.pl 2016-08-18 10:07:06.529441881 +0200 +@@ -0,0 +1,32 @@ ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: IO::Handle ++# ++;# Usage: &flush(FILEHANDLE) ++;# flushes the named filehandle ++ ++;# Usage: &printflush(FILEHANDLE, "prompt: ") ++;# prints arguments and flushes filehandle ++ ++sub flush { ++ local($old) = select(shift); ++ $| = 1; ++ print ""; ++ $| = 0; ++ select($old); ++} ++ ++sub printflush { ++ local($old) = select(shift); ++ $| = 1; ++ print @_; ++ $| = 0; ++ select($old); ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/getcwd.pl perl-5.16.3/lib/getcwd.pl +--- perl-5.16.3-orig/lib/getcwd.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/getcwd.pl 2016-08-18 10:07:06.540441833 +0200 +@@ -0,0 +1,71 @@ ++# By Brandon S. Allbery ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Cwd ++# ++# ++# Usage: $cwd = &getcwd; ++ ++sub getcwd ++{ ++ local($dotdots, $cwd, @pst, @cst, $dir, @tst); ++ ++ unless (@cst = stat('.')) ++ { ++ warn "stat(.): $!"; ++ return ''; ++ } ++ $cwd = ''; ++ do ++ { ++ $dotdots .= '/' if $dotdots; ++ $dotdots .= '..'; ++ @pst = @cst; ++ unless (opendir(getcwd'PARENT, $dotdots)) #')) ++ { ++ warn "opendir($dotdots): $!"; ++ return ''; ++ } ++ unless (@cst = stat($dotdots)) ++ { ++ warn "stat($dotdots): $!"; ++ closedir(getcwd'PARENT); #'); ++ return ''; ++ } ++ if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1]) ++ { ++ $dir = ''; ++ } ++ else ++ { ++ do ++ { ++ unless (defined ($dir = readdir(getcwd'PARENT))) #')) ++ { ++ warn "readdir($dotdots): $!"; ++ closedir(getcwd'PARENT); #'); ++ return ''; ++ } ++ unless (@tst = lstat("$dotdots/$dir")) ++ { ++ # warn "lstat($dotdots/$dir): $!"; ++ # closedir(getcwd'PARENT); #'); ++ # return ''; ++ } ++ } ++ while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || ++ $tst[$[ + 1] != $pst[$[ + 1]); ++ } ++ $cwd = "$dir/$cwd"; ++ closedir(getcwd'PARENT); #'); ++ } while ($dir ne ''); ++ chop($cwd); ++ $cwd; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/getopt.pl perl-5.16.3/lib/getopt.pl +--- perl-5.16.3-orig/lib/getopt.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/getopt.pl 2016-08-18 10:07:06.548441797 +0200 +@@ -0,0 +1,49 @@ ++;# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternatives: Getopt::Long or Getopt::Std ++# ++;# Process single-character switches with switch clustering. Pass one argument ++;# which is a string containing all switches that take an argument. For each ++;# switch found, sets $opt_x (where x is the switch name) to the value of the ++;# argument, or 1 if no argument. Switches which take an argument don't care ++;# whether there is a space between the switch and the argument. ++ ++;# Usage: ++;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. ++ ++sub Getopt { ++ local($argumentative) = @_; ++ local($_,$first,$rest); ++ local($[) = 0; ++ ++ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ++ ($first,$rest) = ($1,$2); ++ if (index($argumentative,$first) >= $[) { ++ if ($rest ne '') { ++ shift(@ARGV); ++ } ++ else { ++ shift(@ARGV); ++ $rest = shift(@ARGV); ++ } ++ ${"opt_$first"} = $rest; ++ } ++ else { ++ ${"opt_$first"} = 1; ++ if ($rest ne '') { ++ $ARGV[0] = "-$rest"; ++ } ++ else { ++ shift(@ARGV); ++ } ++ } ++ } ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/getopts.pl perl-5.16.3/lib/getopts.pl +--- perl-5.16.3-orig/lib/getopts.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/getopts.pl 2016-08-18 10:07:06.557441758 +0200 +@@ -0,0 +1,66 @@ ++;# getopts.pl - a better getopt.pl ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternatives: Getopt::Long or Getopt::Std ++# ++;# Usage: ++;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a ++;# # side effect. ++ ++sub Getopts { ++ local($argumentative) = @_; ++ local(@args,$_,$first,$rest); ++ local($errs) = 0; ++ local($[) = 0; ++ ++ @args = split( / */, $argumentative ); ++ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ++ ($first,$rest) = ($1,$2); ++ $pos = index($argumentative,$first); ++ if($pos >= $[) { ++ if($args[$pos+1] eq ':') { ++ shift(@ARGV); ++ if($rest eq '') { ++ ++$errs unless(@ARGV); ++ $rest = shift(@ARGV); ++ } ++ eval " ++ push(\@opt_$first, \$rest); ++ if (!defined \$opt_$first or \$opt_$first eq '') { ++ \$opt_$first = \$rest; ++ } ++ else { ++ \$opt_$first .= ' ' . \$rest; ++ } ++ "; ++ } ++ else { ++ eval "\$opt_$first = 1"; ++ if($rest eq '') { ++ shift(@ARGV); ++ } ++ else { ++ $ARGV[0] = "-$rest"; ++ } ++ } ++ } ++ else { ++ print STDERR "Unknown option: $first\n"; ++ ++$errs; ++ if($rest ne '') { ++ $ARGV[0] = "-$rest"; ++ } ++ else { ++ shift(@ARGV); ++ } ++ } ++ } ++ $errs == 0; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/hostname.pl perl-5.16.3/lib/hostname.pl +--- perl-5.16.3-orig/lib/hostname.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/hostname.pl 2016-08-18 10:07:06.567441713 +0200 +@@ -0,0 +1,31 @@ ++# From: asherman@fmrco.com (Aaron Sherman) ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Sys::Hostname ++# ++sub hostname ++{ ++ local(*P,@tmp,$hostname,$_); ++ if (open(P,"hostname 2>&1 |") && (@tmp =

) && close(P)) ++ { ++ chop($hostname = $tmp[$#tmp]); ++ } ++ elsif (open(P,"uname -n 2>&1 |") && (@tmp =

) && close(P)) ++ { ++ chop($hostname = $tmp[$#tmp]); ++ } ++ else ++ { ++ die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n"; ++ } ++ @tmp = (); ++ close P; # Just in case we failed in an odd spot.... ++ $hostname; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/importenv.pl perl-5.16.3/lib/importenv.pl +--- perl-5.16.3-orig/lib/importenv.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/importenv.pl 2016-08-18 10:07:06.577441669 +0200 +@@ -0,0 +1,14 @@ ++;# This file, when interpreted, pulls the environment into normal variables. ++;# Usage: ++;# require 'importenv.pl'; ++;# or ++;# #include ++ ++local($tmp,$key) = ''; ++ ++foreach $key (keys(%ENV)) { ++ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; ++} ++eval $tmp; ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/look.pl perl-5.16.3/lib/look.pl +--- perl-5.16.3-orig/lib/look.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/look.pl 2016-08-18 10:07:06.586441630 +0200 +@@ -0,0 +1,50 @@ ++;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++;# Sets file position in FILEHANDLE to be first line greater than or equal ++;# (stringwise) to $key. Pass flags for dictionary order and case folding. ++ ++sub look { ++ local(*FH,$key,$dict,$fold) = @_; ++ local($max,$min,$mid,$_); ++ local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, ++ $blksize,$blocks) = stat(FH); ++ $blksize = 8192 unless $blksize; ++ $key =~ s/[^\w\s]//g if $dict; ++ $key = lc $key if $fold; ++ $max = int($size / $blksize); ++ while ($max - $min > 1) { ++ $mid = int(($max + $min) / 2); ++ seek(FH,$mid * $blksize,0); ++ $_ = if $mid; # probably a partial line ++ $_ = ; ++ chop; ++ s/[^\w\s]//g if $dict; ++ $_ = lc $_ if $fold; ++ if ($_ lt $key) { ++ $min = $mid; ++ } ++ else { ++ $max = $mid; ++ } ++ } ++ $min *= $blksize; ++ seek(FH,$min,0); ++ if $min; ++ while () { ++ chop; ++ s/[^\w\s]//g if $dict; ++ $_ = lc $_ if $fold; ++ last if $_ ge $key; ++ $min = tell(FH); ++ } ++ seek(FH,$min,0); ++ $min; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/newgetopt.pl perl-5.16.3/lib/newgetopt.pl +--- perl-5.16.3-orig/lib/newgetopt.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/newgetopt.pl 2016-08-18 10:07:06.595441590 +0200 +@@ -0,0 +1,75 @@ ++# $Id: newgetopt.pl,v 1.18 2001/09/21 13:34:59 jv Exp $ ++ ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# It is now just a wrapper around the Getopt::Long module. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Getopt::Long ++ ++{ package newgetopt; ++ ++ # Values for $order. See GNU getopt.c for details. ++ $REQUIRE_ORDER = 0; ++ $PERMUTE = 1; ++ $RETURN_IN_ORDER = 2; ++ ++ # Handle POSIX compliancy. ++ if ( defined $ENV{"POSIXLY_CORRECT"} ) { ++ $autoabbrev = 0; # no automatic abbrev of options (???) ++ $getopt_compat = 0; # disallow '+' to start options ++ $option_start = "(--|-)"; ++ $order = $REQUIRE_ORDER; ++ $bundling = 0; ++ $passthrough = 0; ++ } ++ else { ++ $autoabbrev = 1; # automatic abbrev of options ++ $getopt_compat = 1; # allow '+' to start options ++ $option_start = "(--|-|\\+)"; ++ $order = $PERMUTE; ++ $bundling = 0; ++ $passthrough = 0; ++ } ++ ++ # Other configurable settings. ++ $debug = 0; # for debugging ++ $ignorecase = 1; # ignore case when matching options ++ $argv_end = "--"; # don't change this! ++} ++ ++use Getopt::Long; ++ ++################ Subroutines ################ ++ ++sub NGetOpt { ++ ++ $Getopt::Long::debug = $newgetopt::debug ++ if defined $newgetopt::debug; ++ $Getopt::Long::autoabbrev = $newgetopt::autoabbrev ++ if defined $newgetopt::autoabbrev; ++ $Getopt::Long::getopt_compat = $newgetopt::getopt_compat ++ if defined $newgetopt::getopt_compat; ++ $Getopt::Long::option_start = $newgetopt::option_start ++ if defined $newgetopt::option_start; ++ $Getopt::Long::order = $newgetopt::order ++ if defined $newgetopt::order; ++ $Getopt::Long::bundling = $newgetopt::bundling ++ if defined $newgetopt::bundling; ++ $Getopt::Long::ignorecase = $newgetopt::ignorecase ++ if defined $newgetopt::ignorecase; ++ $Getopt::Long::ignorecase = $newgetopt::ignorecase ++ if defined $newgetopt::ignorecase; ++ $Getopt::Long::passthrough = $newgetopt::passthrough ++ if defined $newgetopt::passthrough; ++ ++ &GetOptions; ++} ++ ++################ Package return ################ ++ ++1; ++ ++################ End of newgetopt.pl ################ +diff -ENwbur perl-5.16.3-orig/lib/open2.pl perl-5.16.3/lib/open2.pl +--- perl-5.16.3-orig/lib/open2.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/open2.pl 2016-08-18 10:07:06.605441546 +0200 +@@ -0,0 +1,12 @@ ++# This is a compatibility interface to IPC::Open2. New programs should ++# do ++# ++# use IPC::Open2; ++# ++# instead of ++# ++# require 'open2.pl'; ++ ++package main; ++use IPC::Open2 'open2'; ++1 +diff -ENwbur perl-5.16.3-orig/lib/open3.pl perl-5.16.3/lib/open3.pl +--- perl-5.16.3-orig/lib/open3.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/open3.pl 2016-08-18 10:07:06.615441502 +0200 +@@ -0,0 +1,12 @@ ++# This is a compatibility interface to IPC::Open3. New programs should ++# do ++# ++# use IPC::Open3; ++# ++# instead of ++# ++# require 'open3.pl'; ++ ++package main; ++use IPC::Open3 'open3'; ++1 +diff -ENwbur perl-5.16.3-orig/lib/pwd.pl perl-5.16.3/lib/pwd.pl +--- perl-5.16.3-orig/lib/pwd.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/pwd.pl 2016-08-18 10:07:06.625441458 +0200 +@@ -0,0 +1,67 @@ ++;# pwd.pl - keeps track of current working directory in PWD environment var ++;# ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Cwd ++# ++;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ ++;# ++;# $Log: pwd.pl,v $ ++;# ++;# Usage: ++;# require "pwd.pl"; ++;# &initpwd; ++;# ... ++;# &chdir($newdir); ++ ++package pwd; ++ ++sub main'initpwd { ++ if ($ENV{'PWD'}) { ++ local($dd,$di) = stat('.'); ++ local($pd,$pi) = stat($ENV{'PWD'}); ++ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { ++ chop($ENV{'PWD'} = `pwd`); ++ } ++ } ++ else { ++ chop($ENV{'PWD'} = `pwd`); ++ } ++ if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { ++ local($pd,$pi) = stat($2); ++ local($dd,$di) = stat($1); ++ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { ++ $ENV{'PWD'}="$2$3"; ++ } ++ } ++} ++ ++sub main'chdir { ++ local($newdir) = shift; ++ $newdir =~ s|/{2,}|/|g; ++ if (chdir $newdir) { ++ if ($newdir =~ m#^/#) { ++ $ENV{'PWD'} = $newdir; ++ } ++ else { ++ local(@curdir) = split(m#/#,$ENV{'PWD'}); ++ @curdir = '' unless @curdir; ++ foreach $component (split(m#/#, $newdir)) { ++ next if $component eq '.'; ++ pop(@curdir),next if $component eq '..'; ++ push(@curdir,$component); ++ } ++ $ENV{'PWD'} = join('/',@curdir) || '/'; ++ } ++ } ++ else { ++ 0; ++ } ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/shellwords.pl perl-5.16.3/lib/shellwords.pl +--- perl-5.16.3-orig/lib/shellwords.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/shellwords.pl 2016-08-18 10:07:06.635441413 +0200 +@@ -0,0 +1,14 @@ ++;# shellwords.pl ++;# ++;# Usage: ++;# require 'shellwords.pl'; ++;# @words = shellwords($line); ++;# or ++;# @words = shellwords(@lines); ++;# or ++;# @words = shellwords(); # defaults to $_ (and clobbers it) ++ ++require Text::ParseWords; ++*shellwords = \&Text::ParseWords::old_shellwords; ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/stat.pl perl-5.16.3/lib/stat.pl +--- perl-5.16.3-orig/lib/stat.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/stat.pl 2016-08-18 10:07:06.644441374 +0200 +@@ -0,0 +1,29 @@ ++;# Usage: ++;# require 'stat.pl'; ++;# @ary = stat(foo); ++;# $st_dev = @ary[$ST_DEV]; ++;# ++$ST_DEV = 0 + $[; ++$ST_INO = 1 + $[; ++$ST_MODE = 2 + $[; ++$ST_NLINK = 3 + $[; ++$ST_UID = 4 + $[; ++$ST_GID = 5 + $[; ++$ST_RDEV = 6 + $[; ++$ST_SIZE = 7 + $[; ++$ST_ATIME = 8 + $[; ++$ST_MTIME = 9 + $[; ++$ST_CTIME = 10 + $[; ++$ST_BLKSIZE = 11 + $[; ++$ST_BLOCKS = 12 + $[; ++ ++;# Usage: ++;# require 'stat.pl'; ++;# do Stat('foo'); # sets st_* as a side effect ++;# ++sub Stat { ++ ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, ++ $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/syslog.pl perl-5.16.3/lib/syslog.pl +--- perl-5.16.3-orig/lib/syslog.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/syslog.pl 2016-08-18 10:07:06.656441321 +0200 +@@ -0,0 +1,199 @@ ++# ++# syslog.pl ++# ++# $Log: syslog.pl,v $ ++# ++# tom christiansen ++# modified to use sockets by Larry Wall ++# NOTE: openlog now takes three arguments, just like openlog(3) ++# ++# call syslog() with a string priority and a list of printf() args ++# like syslog(3) ++# ++# usage: require 'syslog.pl'; ++# ++# then (put these all in a script to test function) ++# ++# ++# do openlog($program,'cons,pid','user'); ++# do syslog('info','this is another test'); ++# do syslog('mail|warning','this is a better test: %d', time); ++# do closelog(); ++# ++# do syslog('debug','this is the last test'); ++# do openlog("$program $$",'ndelay','user'); ++# do syslog('notice','fooprogram: this is really done'); ++# ++# $! = 55; ++# do syslog('info','problem was %m'); # %m == $! in syslog(3) ++ ++package syslog; ++ ++use warnings::register; ++ ++$host = 'localhost' unless $host; # set $syslog'host to change ++ ++if ($] >= 5 && warnings::enabled()) { ++ warnings::warn("You should 'use Sys::Syslog' instead; continuing"); ++} ++ ++require 'syslog.ph'; ++ ++ eval 'use Socket; 1' || ++ eval { require "socket.ph" } || ++ require "sys/socket.ph"; ++ ++$maskpri = &LOG_UPTO(&LOG_DEBUG); ++ ++sub main'openlog { ++ ($ident, $logopt, $facility) = @_; # package vars ++ $lo_pid = $logopt =~ /\bpid\b/; ++ $lo_ndelay = $logopt =~ /\bndelay\b/; ++ $lo_cons = $logopt =~ /\bcons\b/; ++ $lo_nowait = $logopt =~ /\bnowait\b/; ++ &connect if $lo_ndelay; ++} ++ ++sub main'closelog { ++ $facility = $ident = ''; ++ &disconnect; ++} ++ ++sub main'setlogmask { ++ local($oldmask) = $maskpri; ++ $maskpri = shift; ++ $oldmask; ++} ++ ++sub main'syslog { ++ local($priority) = shift; ++ local($mask) = shift; ++ local($message, $whoami); ++ local(@words, $num, $numpri, $numfac, $sum); ++ local($facility) = $facility; # may need to change temporarily. ++ ++ die "syslog: expected both priority and mask" unless $mask && $priority; ++ ++ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". ++ undef $numpri; ++ undef $numfac; ++ foreach (@words) { ++ $num = &xlate($_); # Translate word to number. ++ if (/^kern$/ || $num < 0) { ++ die "syslog: invalid level/facility: $_\n"; ++ } ++ elsif ($num <= &LOG_PRIMASK) { ++ die "syslog: too many levels given: $_\n" if defined($numpri); ++ $numpri = $num; ++ return 0 unless &LOG_MASK($numpri) & $maskpri; ++ } ++ else { ++ die "syslog: too many facilities given: $_\n" if defined($numfac); ++ $facility = $_; ++ $numfac = $num; ++ } ++ } ++ ++ die "syslog: level must be given\n" unless defined($numpri); ++ ++ if (!defined($numfac)) { # Facility not specified in this call. ++ $facility = 'user' unless $facility; ++ $numfac = &xlate($facility); ++ } ++ ++ &connect unless $connected; ++ ++ $whoami = $ident; ++ ++ if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { ++ $whoami = $1; ++ $mask = $2; ++ } ++ ++ unless ($whoami) { ++ ($whoami = getlogin) || ++ ($whoami = getpwuid($<)) || ++ ($whoami = 'syslog'); ++ } ++ ++ $whoami .= "[$$]" if $lo_pid; ++ ++ $mask =~ s/%m/$!/g; ++ $mask .= "\n" unless $mask =~ /\n$/; ++ $message = sprintf ($mask, @_); ++ ++ $sum = $numpri + $numfac; ++ unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { ++ if ($lo_cons) { ++ if ($pid = fork) { ++ unless ($lo_nowait) { ++ do {$died = wait;} until $died == $pid || $died < 0; ++ } ++ } ++ else { ++ open(CONS,">/dev/console"); ++ print CONS "<$facility.$priority>$whoami: $message\r"; ++ exit if defined $pid; # if fork failed, we're parent ++ close CONS; ++ } ++ } ++ } ++} ++ ++sub xlate { ++ local($name) = @_; ++ $name = uc $name; ++ $name = "LOG_$name" unless $name =~ /^LOG_/; ++ $name = "syslog'$name"; ++ defined &$name ? &$name : -1; ++} ++ ++sub connect { ++ $pat = 'S n C4 x8'; ++ ++ $af_unix = &AF_UNIX; ++ $af_inet = &AF_INET; ++ ++ $stream = &SOCK_STREAM; ++ $datagram = &SOCK_DGRAM; ++ ++ ($name,$aliases,$proto) = getprotobyname('udp'); ++ $udp = $proto; ++ ++ ($name,$aliases,$port,$proto) = getservbyname('syslog','udp'); ++ $syslog = $port; ++ ++ if (chop($myname = `hostname`)) { ++ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); ++ die "Can't lookup $myname\n" unless $name; ++ @bytes = unpack("C4",$addrs[0]); ++ } ++ else { ++ @bytes = (0,0,0,0); ++ } ++ $this = pack($pat, $af_inet, 0, @bytes); ++ ++ if ($host =~ /^\d+\./) { ++ @bytes = split(/\./,$host); ++ } ++ else { ++ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); ++ die "Can't lookup $host\n" unless $name; ++ @bytes = unpack("C4",$addrs[0]); ++ } ++ $that = pack($pat,$af_inet,$syslog,@bytes); ++ ++ socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; ++ bind(SYSLOG,$this) || die "bind: $!\n"; ++ connect(SYSLOG,$that) || die "connect: $!\n"; ++ ++ local($old) = select(SYSLOG); $| = 1; select($old); ++ $connected = 1; ++} ++ ++sub disconnect { ++ close SYSLOG; ++ $connected = 0; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/tainted.pl perl-5.16.3/lib/tainted.pl +--- perl-5.16.3-orig/lib/tainted.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/tainted.pl 2016-08-18 10:07:06.670441259 +0200 +@@ -0,0 +1,9 @@ ++# This subroutine returns true if its argument is tainted, false otherwise. ++ ++sub tainted { ++ local($@); ++ eval { kill 0 * $_[0] }; ++ $@ =~ /^Insecure/; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/termcap.pl perl-5.16.3/lib/termcap.pl +--- perl-5.16.3-orig/lib/termcap.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/termcap.pl 2016-08-18 10:07:06.678441224 +0200 +@@ -0,0 +1,178 @@ ++;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ ++# ++# This library is no longer being maintained, and is included for backward ++# compatibility with Perl 4 programs which may require it. ++# ++# In particular, this should not be used as an example of modern Perl ++# programming techniques. ++# ++# Suggested alternative: Term::Cap ++# ++;# ++;# Usage: ++;# require 'ioctl.pl'; ++;# ioctl(TTY,$TIOCGETP,$foo); ++;# ($ispeed,$ospeed) = unpack('cc',$foo); ++;# require 'termcap.pl'; ++;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. ++;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); ++;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); ++;# ++sub Tgetent { ++ local($TERM) = @_; ++ local($TERMCAP,$_,$entry,$loop,$field); ++ ++ # warn "Tgetent: no ospeed set" unless $ospeed; ++ foreach $key (keys %TC) { ++ delete $TC{$key}; ++ } ++ $TERM = $ENV{'TERM'} unless $TERM; ++ $TERM =~ s/(\W)/\\$1/g; ++ $TERMCAP = $ENV{'TERMCAP'}; ++ $TERMCAP = '/etc/termcap' unless $TERMCAP; ++ if ($TERMCAP !~ m:^/:) { ++ if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { ++ $TERMCAP = '/etc/termcap'; ++ } ++ } ++ if ($TERMCAP =~ m:^/:) { ++ $entry = ''; ++ do { ++ $loop = " ++ open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\"; ++ while () { ++ next if /^#/; ++ next if /^\t/; ++ if (/(^|\\|)${TERM}[:\\|]/) { ++ chop; ++ while (chop eq '\\\\') { ++ \$_ .= ; ++ chop; ++ } ++ \$_ .= ':'; ++ last; ++ } ++ } ++ close TERMCAP; ++ \$entry .= \$_; ++ "; ++ eval $loop; ++ } while s/:tc=([^:]+):/:/ && ($TERM = $1); ++ $TERMCAP = $entry; ++ } ++ ++ foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { ++ if ($field =~ /^\w\w$/) { ++ $TC{$field} = 1; ++ } ++ elsif ($field =~ /^(\w\w)#(.*)/) { ++ $TC{$1} = $2 if $TC{$1} eq ''; ++ } ++ elsif ($field =~ /^(\w\w)=(.*)/) { ++ $entry = $1; ++ $_ = $2; ++ s/\\E/\033/g; ++ s/\\(200)/pack('c',0)/eg; # NUL character ++ s/\\(0\d\d)/pack('c',oct($1))/eg; # octal ++ s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex ++ s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; ++ s/\\n/\n/g; ++ s/\\r/\r/g; ++ s/\\t/\t/g; ++ s/\\b/\b/g; ++ s/\\f/\f/g; ++ s/\\\^/\377/g; ++ s/\^\?/\177/g; ++ s/\^(.)/pack('c',ord($1) & 31)/eg; ++ s/\\(.)/$1/g; ++ s/\377/^/g; ++ $TC{$entry} = $_ if $TC{$entry} eq ''; ++ } ++ } ++ $TC{'pc'} = "\0" if $TC{'pc'} eq ''; ++ $TC{'bc'} = "\b" if $TC{'bc'} eq ''; ++} ++ ++@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); ++ ++sub Tputs { ++ local($string,$affcnt,$FH) = @_; ++ local($ms); ++ if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { ++ $ms = $1; ++ $ms *= $affcnt if $2; ++ $string = $3; ++ $decr = $Tputs[$ospeed]; ++ if ($decr > .1) { ++ $ms += $decr / 2; ++ $string .= $TC{'pc'} x ($ms / $decr); ++ } ++ } ++ print $FH $string if $FH; ++ $string; ++} ++ ++sub Tgoto { ++ local($string) = shift(@_); ++ local($result) = ''; ++ local($after) = ''; ++ local($code,$tmp) = @_; ++ local(@tmp); ++ @tmp = ($tmp,$code); ++ local($online) = 0; ++ while ($string =~ /^([^%]*)%(.)(.*)/) { ++ $result .= $1; ++ $code = $2; ++ $string = $3; ++ if ($code eq 'd') { ++ $result .= sprintf("%d",shift(@tmp)); ++ } ++ elsif ($code eq '.') { ++ $tmp = shift(@tmp); ++ if ($tmp == 0 || $tmp == 4 || $tmp == 10) { ++ if ($online) { ++ ++$tmp, $after .= $TC{'up'} if $TC{'up'}; ++ } ++ else { ++ ++$tmp, $after .= $TC{'bc'}; ++ } ++ } ++ $result .= sprintf("%c",$tmp); ++ $online = !$online; ++ } ++ elsif ($code eq '+') { ++ $result .= sprintf("%c",shift(@tmp)+ord($string)); ++ $string = substr($string,1,99); ++ $online = !$online; ++ } ++ elsif ($code eq 'r') { ++ ($code,$tmp) = @tmp; ++ @tmp = ($tmp,$code); ++ $online = !$online; ++ } ++ elsif ($code eq '>') { ++ ($code,$tmp,$string) = unpack("CCa99",$string); ++ if ($tmp[$[] > $code) { ++ $tmp[$[] += $tmp; ++ } ++ } ++ elsif ($code eq '2') { ++ $result .= sprintf("%02d",shift(@tmp)); ++ $online = !$online; ++ } ++ elsif ($code eq '3') { ++ $result .= sprintf("%03d",shift(@tmp)); ++ $online = !$online; ++ } ++ elsif ($code eq 'i') { ++ ($code,$tmp) = @tmp; ++ @tmp = ($code+1,$tmp+1); ++ } ++ else { ++ return "OOPS"; ++ } ++ } ++ $result . $string . $after; ++} ++ ++1; +diff -ENwbur perl-5.16.3-orig/lib/timelocal.pl perl-5.16.3/lib/timelocal.pl +--- perl-5.16.3-orig/lib/timelocal.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/timelocal.pl 2016-08-18 10:07:06.689441175 +0200 +@@ -0,0 +1,18 @@ ++;# timelocal.pl ++;# ++;# Usage: ++;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); ++;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); ++ ++;# This file has been superseded by the Time::Local library module. ++;# It is implemented as a call to that module for backwards compatibility ++;# with code written for perl4; new code should use Time::Local directly. ++ ++;# The current implementation shares with the original the questionable ++;# behavior of defining the timelocal() and timegm() functions in the ++;# namespace of whatever package was current when the first instance of ++;# C was executed in a program. ++ ++use Time::Local; ++ ++*timelocal::cheat = \&Time::Local::cheat; +diff -ENwbur perl-5.16.3-orig/lib/validate.pl perl-5.16.3/lib/validate.pl +--- perl-5.16.3-orig/lib/validate.pl 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.16.3/lib/validate.pl 2016-08-18 10:07:06.696441144 +0200 +@@ -0,0 +1,102 @@ ++;# The validate routine takes a single multiline string consisting of ++;# lines containing a filename plus a file test to try on it. (The ++;# file test may also be a 'cd', causing subsequent relative filenames ++;# to be interpreted relative to that directory.) After the file test ++;# you may put '|| die' to make it a fatal error if the file test fails. ++;# The default is '|| warn'. The file test may optionally have a ! prepended ++;# to test for the opposite condition. If you do a cd and then list some ++;# relative filenames, you may want to indent them slightly for readability. ++;# If you supply your own "die" or "warn" message, you can use $file to ++;# interpolate the filename. ++ ++;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. ++;# Only the first failed test of the bunch will produce a warning. ++ ++;# The routine returns the number of warnings issued. ++ ++;# Usage: ++;# require "validate.pl"; ++;# $warnings += do validate(' ++;# /vmunix -e || die ++;# /boot -e || die ++;# /bin cd ++;# csh -ex ++;# csh !-ug ++;# sh -ex ++;# sh !-ug ++;# /usr -d || warn "What happened to $file?\n" ++;# '); ++ ++sub validate { ++ local($file,$test,$warnings,$oldwarnings); ++ foreach $check (split(/\n/,$_[0])) { ++ next if $check =~ /^#/; ++ next if $check =~ /^$/; ++ ($file,$test) = split(' ',$check,2); ++ if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { ++ $testlist = $2; ++ @testlist = split(//,$testlist); ++ } ++ else { ++ @testlist = ('Z'); ++ } ++ $oldwarnings = $warnings; ++ foreach $one (@testlist) { ++ $this = $test; ++ $this =~ s/(-\w\b)/$1 \$file/g; ++ $this =~ s/-Z/-$one/; ++ $this .= ' || warn' unless $this =~ /\|\|/; ++ $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; ++ $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; ++ eval $this; ++ last if $warnings > $oldwarnings; ++ } ++ } ++ $warnings; ++} ++ ++sub valmess { ++ local($disposition,$this) = @_; ++ $file = $cwd . '/' . $file unless $file =~ m|^/|; ++ if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { ++ $neg = $1; ++ $tmp = $2; ++ $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); ++ $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); ++ $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); ++ $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); ++ $tmp eq 'R' && ($mess = "$file is not readable by you."); ++ $tmp eq 'W' && ($mess = "$file is not writable by you."); ++ $tmp eq 'X' && ($mess = "$file is not executable by you."); ++ $tmp eq 'O' && ($mess = "$file is not owned by you."); ++ $tmp eq 'e' && ($mess = "$file does not exist."); ++ $tmp eq 'z' && ($mess = "$file does not have zero size."); ++ $tmp eq 's' && ($mess = "$file does not have non-zero size."); ++ $tmp eq 'f' && ($mess = "$file is not a plain file."); ++ $tmp eq 'd' && ($mess = "$file is not a directory."); ++ $tmp eq 'l' && ($mess = "$file is not a symbolic link."); ++ $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); ++ $tmp eq 'S' && ($mess = "$file is not a socket."); ++ $tmp eq 'b' && ($mess = "$file is not a block special file."); ++ $tmp eq 'c' && ($mess = "$file is not a character special file."); ++ $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); ++ $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); ++ $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); ++ $tmp eq 'T' && ($mess = "$file is not a text file."); ++ $tmp eq 'B' && ($mess = "$file is not a binary file."); ++ if ($neg eq '!') { ++ $mess =~ s/ is not / should not be / || ++ $mess =~ s/ does not / should not / || ++ $mess =~ s/ not / /; ++ } ++ print STDERR $mess,"\n"; ++ } ++ else { ++ $this =~ s/\$file/'$file'/g; ++ print STDERR "Can't do $this.\n"; ++ } ++ if ($disposition eq 'die') { exit 1; } ++ ++$warnings; ++} ++ ++1; diff --git a/SOURCES/perl-5.16.3-File-Glob-Dup-glob-state-in-CLONE.patch b/SOURCES/perl-5.16.3-File-Glob-Dup-glob-state-in-CLONE.patch new file mode 100644 index 0000000..a26b585 --- /dev/null +++ b/SOURCES/perl-5.16.3-File-Glob-Dup-glob-state-in-CLONE.patch @@ -0,0 +1,177 @@ +From faa03ffb8ccbf754d38d041570fcf2ce8816f36b Mon Sep 17 00:00:00 2001 +From: =?UTF-8?q?Petr=20=C5=A0abata?= +Date: Wed, 2 Sep 2015 16:24:58 +0200 +Subject: [PATCH] File::Glob: Dup glob state in CLONE() +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +File::Glob: Dup glob state in CLONE() + +This solves [perl #119897] and [perl #117823], and restores the +behavior of glob() in conjunction with threads of 5.14 and older. + +Since 5.16, code that used glob() inside a thread had been +unintentionally sharing state between threads, which lead to things +like this crashing and failing assertions: + +./perl -Ilib -Mthreads -e 'scalar glob("*"); threads->create(sub { glob("*") })->join();' + +Signed-off-by: Petr Šabata +--- + MANIFEST | 1 + + ext/File-Glob/Glob.xs | 33 ++++++++++++++++++++++ + ext/File-Glob/t/threads.t | 71 +++++++++++++++++++++++++++++++++++++++++++++++ + 3 files changed, 105 insertions(+) + create mode 100644 ext/File-Glob/t/threads.t + +diff --git a/MANIFEST b/MANIFEST +index 181bb3f..9771022 100644 +--- a/MANIFEST ++++ b/MANIFEST +@@ -3683,6 +3683,7 @@ ext/File-Glob/t/global.t See if File::Glob works + ext/File-Glob/TODO File::Glob extension todo list + ext/File-Glob/t/rt114984.t See if File::Glob works + ext/File-Glob/t/taint.t See if File::Glob works ++ext/File-Glob/t/threads.t See if File::Glob + threads works + ext/GDBM_File/GDBM_File.pm GDBM extension Perl module + ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines + ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture +diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs +index d74e7a4..6c69aa6 100644 +--- a/ext/File-Glob/Glob.xs ++++ b/ext/File-Glob/Glob.xs +@@ -9,6 +9,9 @@ + #define MY_CXT_KEY "File::Glob::_guts" XS_VERSION + + typedef struct { ++#ifdef USE_ITHREADS ++ tTHX interp; ++#endif + int x_GLOB_ERROR; + HV * x_GLOB_ENTRIES; + } my_cxt_t; +@@ -380,6 +383,33 @@ PPCODE: + iterate(aTHX_ doglob_iter_wrapper); + SPAGAIN; + ++#ifdef USE_ITHREADS ++ ++void ++CLONE(...) ++INIT: ++ HV *glob_entries_clone = NULL; ++CODE: ++ PERL_UNUSED_ARG(items); ++ { ++ dMY_CXT; ++ if ( MY_CXT.x_GLOB_ENTRIES ) { ++ CLONE_PARAMS param; ++ param.stashes = NULL; ++ param.flags = 0; ++ param.proto_perl = MY_CXT.interp; ++ ++ glob_entries_clone = MUTABLE_HV(sv_dup_inc((SV*)MY_CXT.x_GLOB_ENTRIES, ¶m)); ++ } ++ } ++ { ++ MY_CXT_CLONE; ++ MY_CXT.x_GLOB_ENTRIES = glob_entries_clone; ++ MY_CXT.interp = aTHX; ++ } ++ ++#endif ++ + BOOT: + { + #ifndef PERL_EXTERNAL_GLOB +@@ -394,6 +424,9 @@ BOOT: + { + dMY_CXT; + MY_CXT.x_GLOB_ENTRIES = NULL; ++#ifdef USE_ITHREADS ++ MY_CXT.interp = aTHX; ++#endif + } + } + +diff --git a/ext/File-Glob/t/threads.t b/ext/File-Glob/t/threads.t +new file mode 100644 +index 0000000..141450a +--- /dev/null ++++ b/ext/File-Glob/t/threads.t +@@ -0,0 +1,71 @@ ++#!./perl ++ ++BEGIN { ++ chdir 't' if -d 't'; ++ @INC = '../lib'; ++ require Config; import Config; ++ if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { ++ print "1..0\n"; ++ exit 0; ++ } ++} ++use strict; ++use warnings; ++# Test::More needs threads pre-loaded ++use if $Config{useithreads}, 'threads'; ++use Test::More; ++ ++BEGIN { ++ if (! $Config{'useithreads'}) { ++ plan skip_all => "Perl not compiled with 'useithreads'"; ++ } ++} ++ ++use File::Temp qw(tempdir); ++use File::Spec qw(); ++use File::Glob qw(csh_glob); ++ ++my($dir) = tempdir(CLEANUP => 1) ++ or die "Could not create temporary directory"; ++ ++my @temp_files = qw(1_file 2_file 3_file); ++for my $file (@temp_files) { ++ open my $fh, ">", File::Spec->catfile($dir, $file) ++ or die "Could not create file $dir/$file: $!"; ++ close $fh; ++} ++my $cwd = Cwd::cwd(); ++chdir $dir ++ or die "Could not chdir to $dir: $!"; ++ ++sub do_glob { scalar csh_glob("*") } ++# Stablish some glob state ++my $first_file = do_glob(); ++is($first_file, $temp_files[0]); ++ ++my @files; ++push @files, threads->create(\&do_glob)->join() for 1..5; ++is_deeply( ++ \@files, ++ [($temp_files[1]) x 5], ++ "glob() state is cloned for new threads" ++); ++ ++@files = threads->create({'context' => 'list'}, ++ sub { ++ return do_glob(), threads->create(\&do_glob)->join() ++ })->join(); ++ ++is_deeply( ++ \@files, ++ [@temp_files[1,2]], ++ "..and for new threads inside threads" ++); ++ ++my $second_file = do_glob(); ++is($second_file, $temp_files[1], "state doesn't leak from threads"); ++ ++chdir $cwd ++ or die "Could not chdir back to $cwd: $!"; ++ ++done_testing; +-- +2.4.3 + diff --git a/SOURCES/perl-5.16.3-Fix-incorrect-handling-of-CRLF-in-Net-FTP.patch b/SOURCES/perl-5.16.3-Fix-incorrect-handling-of-CRLF-in-Net-FTP.patch new file mode 100644 index 0000000..eadad5b --- /dev/null +++ b/SOURCES/perl-5.16.3-Fix-incorrect-handling-of-CRLF-in-Net-FTP.patch @@ -0,0 +1,38 @@ +From 7c8b0c1259db2bdd372cc1bdb63bf5b89a969a4a Mon Sep 17 00:00:00 2001 +From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= +Date: Tue, 27 Oct 2015 16:33:43 +0100 +Subject: [PATCH] Fix incorrect handling of CRLF in Net::FTP +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +libnet upstream commit ported to perl-5.16.3: + +From 24eb8619451c3d8529d903d9133d03a7f447488f Mon Sep 17 00:00:00 2001 +From: Steve Hay +Date: Fri, 3 Jan 2014 17:41:55 +0000 +Subject: [PATCH] Fix incorrect handling of CRLF in Net::FTP + +Signed-off-by: Petr Písař +--- + cpan/libnet/Net/FTP/A.pm | 4 ++-- + 1 file changed, 2 insertions(+), 2 deletions(-) + +diff --git a/cpan/libnet/Net/FTP/A.pm b/cpan/libnet/Net/FTP/A.pm +index 427d02b..886d252 100644 +--- a/cpan/libnet/Net/FTP/A.pm ++++ b/cpan/libnet/Net/FTP/A.pm +@@ -77,8 +77,8 @@ sub write { + my $timeout = @_ ? shift: $data->timeout; + + my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/; +- $tmp =~ s/([^\015])\012/$1\015\012/sg if $nr; +- $tmp =~ s/^\012/\015\012/ unless ${*$data}{'net_ftp_outcr'}; ++ $tmp =~ s/(? +Date: Fri, 28 Aug 2015 14:17:00 -0300 +Subject: [PATCH] Properly duplicate PerlIO::encoding objects +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +Upstream commit ported to 5.16.3: + +commit 0ee3fa26f660ac426e3e082f77d806c9d1471f93 +Author: Vincent Pit +Date: Fri Aug 28 14:17:00 2015 -0300 + + Properly duplicate PerlIO::encoding objects + + PerlIO::encoding objects are usually initialized by calling Perl methods, + essentially from the pushed() and getarg() callbacks. During cloning, the + PerlIO API will by default call these methods to initialize the duplicate + struct when the PerlIOBase parent struct is itself duplicated. This does + not behave so well because the perl interpreter is not ready to call + methods at this point, for the stacks are not set up yet. + + The proper way to duplicate the PerlIO::encoding object is to call sv_dup() + on its members from the dup() PerlIO callback. So the only catch is to make + the getarg() and pushed() calls implied by the duplication of the underlying + PerlIOBase object aware that they are called during cloning, and make them + wait that the control flow returns to the dup() callback. Fortunately, + getarg() knows since its param argument is then non-null, and its return + value is passed immediately to pushed(), so it is enough to tag this + returned value with a custom magic so that pushed() can see it is being + called during cloning. + + This fixes [RT #31923]. + +Signed-off-by: Petr Písař +--- + MANIFEST | 1 + + ext/PerlIO-encoding/encoding.xs | 25 +++++++++++++++++++++++-- + ext/PerlIO-encoding/t/threads.t | 35 +++++++++++++++++++++++++++++++++++ + 3 files changed, 59 insertions(+), 2 deletions(-) + create mode 100644 ext/PerlIO-encoding/t/threads.t + +diff --git a/MANIFEST b/MANIFEST +index 02e8234..5caa981 100644 +--- a/MANIFEST ++++ b/MANIFEST +@@ -3791,6 +3791,7 @@ ext/PerlIO-encoding/MANIFEST PerlIO::encoding list of files + ext/PerlIO-encoding/t/encoding.t See if PerlIO encoding conversion works + ext/PerlIO-encoding/t/fallback.t See if PerlIO fallbacks work + ext/PerlIO-encoding/t/nolooping.t Tests for PerlIO::encoding ++ext/PerlIO-encoding/t/threads.t Tests PerlIO::encoding and threads + ext/PerlIO-mmap/mmap.pm PerlIO layer for memory maps + ext/PerlIO-mmap/mmap.xs PerlIO layer for memory maps + ext/PerlIO-scalar/scalar.pm PerlIO layer for scalars +diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs +index 98d89e9..d5efb62 100644 +--- a/ext/PerlIO-encoding/encoding.xs ++++ b/ext/PerlIO-encoding/encoding.xs +@@ -49,13 +49,23 @@ typedef struct { + + #define NEEDS_LINES 1 + ++static const MGVTBL PerlIOEncode_tag = { 0, 0, 0, 0, 0, 0, 0, 0 }; ++ + SV * + PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) + { + PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); +- SV *sv = &PL_sv_undef; +- PERL_UNUSED_ARG(param); ++ SV *sv; + PERL_UNUSED_ARG(flags); ++ /* During cloning, return an undef token object so that _pushed() knows ++ * that it should not call methods and wait for _dup() to actually dup the ++ * encoding object. */ ++ if (param) { ++ sv = newSV(0); ++ sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOEncode_tag, 0, 0); ++ return sv; ++ } ++ sv = &PL_sv_undef; + if (e->enc) { + dSP; + /* Not 100% sure stack swap is right thing to do during dup ... */ +@@ -86,6 +96,14 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * + IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab); + SV *result = Nullsv; + ++ if (SvTYPE(arg) >= SVt_PVMG ++ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOEncode_tag)) { ++ e->enc = NULL; ++ e->chk = NULL; ++ e->inEncodeCall = 0; ++ return code; ++ } ++ + PUSHSTACKi(PERLSI_MAGIC); + SPAGAIN; + +@@ -558,6 +576,9 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, + if (oe->enc) { + fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params); + } ++ if (oe->chk) { ++ fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params); ++ } + } + return f; + } +diff --git a/ext/PerlIO-encoding/t/threads.t b/ext/PerlIO-encoding/t/threads.t +new file mode 100644 +index 0000000..64f0e55 +--- /dev/null ++++ b/ext/PerlIO-encoding/t/threads.t +@@ -0,0 +1,35 @@ ++#!perl ++ ++use strict; ++use warnings; ++ ++BEGIN { ++ use Config; ++ if ($Config{extensions} !~ /\bEncode\b/) { ++ print "1..0 # Skip: no Encode\n"; ++ exit 0; ++ } ++ unless ($Config{useithreads}) { ++ print "1..0 # Skip: no threads\n"; ++ exit 0; ++ } ++} ++ ++use threads; ++ ++use Test::More tests => 3 + 1; ++ ++binmode *STDOUT, ':encoding(UTF-8)'; ++ ++SKIP: { ++ local $@; ++ my $ret = eval { ++ my $thread = threads->create(sub { pass 'in thread'; return 1 }); ++ skip 'test thread could not be spawned' => 3 unless $thread; ++ $thread->join; ++ }; ++ is $@, '', 'thread did not croak'; ++ is $ret, 1, 'thread returned the right value'; ++} ++ ++pass 'passes at least one test'; +-- +2.5.5 + diff --git a/SOURCES/perl-5.20.3-Don-t-leak-the-temp-utf8-copy-of-n.patch b/SOURCES/perl-5.20.3-Don-t-leak-the-temp-utf8-copy-of-n.patch new file mode 100644 index 0000000..811584a --- /dev/null +++ b/SOURCES/perl-5.20.3-Don-t-leak-the-temp-utf8-copy-of-n.patch @@ -0,0 +1,33 @@ +From 8d89c0509dd5eb1de58dc6617f6e08599eb24792 Mon Sep 17 00:00:00 2001 +From: Tony Cook +Date: Mon, 10 Aug 2015 13:37:26 +0100 +Subject: [PATCH] [PATCH] [perl #123786] don't leak the temp utf8 copy of + namepv +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +Signed-off-by: Petr Písař +--- + pad.c | 4 +++- + 1 file changed, 3 insertions(+), 1 deletion(-) + +diff --git a/pad.c b/pad.c +index fed2892..f22c3c5 100644 +--- a/pad.c ++++ b/pad.c +@@ -976,8 +976,10 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) + + if (is_utf8) + flags |= padadd_UTF8_NAME; +- else ++ else { + flags &= ~padadd_UTF8_NAME; ++ SAVEFREEPV(namepv); ++ } + } + + offset = pad_findlex(namepv, namelen, flags, +-- +2.4.3 + diff --git a/SPECS/perl.spec b/SPECS/perl.spec index 6be225d..ecf67b0 100644 --- a/SPECS/perl.spec +++ b/SPECS/perl.spec @@ -31,7 +31,7 @@ Name: perl Version: %{perl_version} # release number must be even higher, because dual-lived modules will be broken otherwise -Release: 286%{?dist} +Release: 291%{?dist} Epoch: %{perl_epoch} Summary: Practical Extraction and Report Language Group: Development/Languages @@ -151,6 +151,24 @@ Patch32: perl-5.16.3-t-op-taint.t-Perform-SHA-256-algorithm-by-crypt-if-d # in upstream after 5.19.1 Patch33: perl-5.16.3-Benchmark.t-remove-CPU-speed-sensitive-test.patch +# Make File::Glob work with threads again, bug #1223045 +# RT#119897, in upstream after 5.19.5 +Patch34: perl-5.16.3-File-Glob-Dup-glob-state-in-CLONE.patch + +# Fix CRLF conversion in ASCII FTP upload, bug #1263734, CPAN RT#41642 +Patch35: perl-5.16.3-Fix-incorrect-handling-of-CRLF-in-Net-FTP.patch + +# Don't leak the temp utf8 copy of namepv, bug #1063330, CPAN RT#123786 +Patch36: perl-5.20.3-Don-t-leak-the-temp-utf8-copy-of-n.patch + +# Fix duplicating PerlIO::encoding when spawning threads, bug #1344749, +# RT#31923, in upstream after 5.23.3 +Patch37: perl-5.16.3-Properly-duplicate-PerlIO-encoding-objects.patch + +# Backported libraries historically supplied with Perl 4 from Perl 5.10.1. +# It is used as a workaround before adding perl-Perl4-CoreLibs to RHEL 7 +Patch38: Backport-Perl4-CoreLibs.patch + # Update some of the bundled modules # see http://fedoraproject.org/wiki/Perl/perl.spec for instructions @@ -183,42 +201,10 @@ Provides: perl(:WITH_LARGEFILES) # PerlIO provides Provides: perl(:WITH_PERLIO) # File provides -Provides: perl(abbrev.pl) -Provides: perl(assert.pl) -Provides: perl(bigfloat.pl) -Provides: perl(bigint.pl) -Provides: perl(bigrat.pl) Provides: perl(bytes_heavy.pl) -Provides: perl(cacheout.pl) -Provides: perl(complete.pl) -Provides: perl(ctime.pl) -Provides: perl(dotsh.pl) Provides: perl(dumpvar.pl) -Provides: perl(exceptions.pl) -Provides: perl(fastcwd.pl) -Provides: perl(find.pl) -Provides: perl(finddepth.pl) -Provides: perl(flush.pl) -Provides: perl(ftp.pl) -Provides: perl(getcwd.pl) -Provides: perl(getopt.pl) -Provides: perl(getopts.pl) -Provides: perl(hostname.pl) -Provides: perl(importenv.pl) -Provides: perl(look.pl) -Provides: perl(newgetopt.pl) -Provides: perl(open2.pl) -Provides: perl(open3.pl) Provides: perl(perl5db.pl) -Provides: perl(pwd.pl) -Provides: perl(shellwords.pl) -Provides: perl(stat.pl) -Provides: perl(syslog.pl) -Provides: perl(tainted.pl) -Provides: perl(termcap.pl) -Provides: perl(timelocal.pl) Provides: perl(utf8_heavy.pl) -Provides: perl(validate.pl) # suidperl isn't created by upstream since 5.12.0 Obsoletes: perl-suidperl <= 4:5.12.2 @@ -1390,6 +1376,61 @@ Parse::CPAN::Meta is a parser for META.yml files, based on the parser half of YAML::Tiny. %endif +%package Perl4-CoreLibs +Summary: Libraries historically supplied with Perl 4 +Version: 0.001 +Epoch: 0 +License: GPL+ or Artistic +Group: Development/Libraries +BuildArch: noarch +Requires: %perl_compat +Requires: perl(File::Find) +Requires: perl(IPC::Open2) +Requires: perl(IPC::Open3) +Requires: perl(Socket) +Requires: perl(Text::ParseWords) >= 3.25 +Requires: perl(Time::Local) +Requires: perl(warnings::register) +Provides: perl(abbrev.pl) +Provides: perl(assert.pl) +Provides: perl(bigfloat.pl) +Provides: perl(bigint.pl) +Provides: perl(bigrat.pl) +Provides: perl(cacheout.pl) +Provides: perl(complete.pl) +Provides: perl(ctime.pl) +Provides: perl(dotsh.pl) +Provides: perl(exceptions.pl) +Provides: perl(fastcwd.pl) +Provides: perl(find.pl) +Provides: perl(finddepth.pl) +Provides: perl(flush.pl) +Provides: perl(getcwd.pl) +Provides: perl(getopt.pl) +Provides: perl(getopts.pl) +Provides: perl(hostname.pl) +Provides: perl(importenv.pl) +Provides: perl(look.pl) +Provides: perl(newgetopt.pl) +Provides: perl(open2.pl) +Provides: perl(open3.pl) +Provides: perl(pwd.pl) +Provides: perl(shellwords.pl) +Provides: perl(stat.pl) +Provides: perl(syslog.pl) +Provides: perl(tainted.pl) +Provides: perl(termcap.pl) +Provides: perl(timelocal.pl) +Provides: perl(validate.pl) + +%description Perl4-CoreLibs +This is a collection of .pl files that have historically been bundled with the +Perl core and were removed from perl 5.16. These files should not be used by +new code. Functionally, most have been directly superseded by modules in the +Perl 5 style. This collection exists to support old Perl programs that +predates satisfactory replacements. + + %if %{dual_life} || %{rebuild_from_scratch} %package Perl-OSType Summary: Map Perl operating system names to generic types @@ -1968,6 +2009,11 @@ tarball from perl.org. %patch31 -p1 %patch32 -p1 %patch33 -p1 +%patch34 -p1 +%patch35 -p1 +%patch36 -p1 +%patch37 -p1 +%patch38 -p1 %if !%{defined perl_bootstrap} # Local patch tracking @@ -2003,6 +2049,11 @@ perl -x patchlevel.h \ 'RHEL Patch31: Make *DBM_File desctructors thread-safe (RT#61912)' \ 'RHEL Patch32: Use stronger algorithm needed for FIPS in t/op/taint.t (RT#123338)' \ 'RHEL Patch33: Remove CPU-speed-sensitive test in Benchmark test' \ + 'RHEL Patch34: Make File::Glob work with threads again' \ + 'RHEL Patch35: Fix CRLF conversion in ASCII FTP upload (CPAN RT#41642)' \ + 'RHEL Patch36: Do not leak the temp utf8 copy of namepv (CPAN RT#123786)' \ + 'RHEL Patch37: Fix duplicating PerlIO::encoding when spawning threads (RT#31923)' \ + 'RHEL Patch38: Backported libraries historically supplied with Perl 4' \ %{nil} %endif @@ -2708,6 +2759,40 @@ sed \ %exclude %{privlib}/Params/ %exclude %{_mandir}/man3/Params::Check* +# Perl4-CoreLibs +%exclude %{privlib}/abbrev.pl +%exclude %{privlib}/assert.pl +%exclude %{privlib}/bigfloat.pl +%exclude %{privlib}/bigint.pl +%exclude %{privlib}/bigrat.pl +%exclude %{privlib}/cacheout.pl +%exclude %{privlib}/complete.pl +%exclude %{privlib}/ctime.pl +%exclude %{privlib}/dotsh.pl +%exclude %{privlib}/exceptions.pl +%exclude %{privlib}/fastcwd.pl +%exclude %{privlib}/find.pl +%exclude %{privlib}/finddepth.pl +%exclude %{privlib}/flush.pl +%exclude %{privlib}/getcwd.pl +%exclude %{privlib}/getopt.pl +%exclude %{privlib}/getopts.pl +%exclude %{privlib}/hostname.pl +%exclude %{privlib}/importenv.pl +%exclude %{privlib}/look.pl +%exclude %{privlib}/newgetopt.pl +%exclude %{privlib}/open2.pl +%exclude %{privlib}/open3.pl +%exclude %{privlib}/pwd.pl +%exclude %{privlib}/shellwords.pl +%exclude %{privlib}/stat.pl +%exclude %{privlib}/syslog.pl +%exclude %{privlib}/tainted.pl +%exclude %{privlib}/termcap.pl +%exclude %{privlib}/timelocal.pl +%exclude %{privlib}/validate.pl + + # Perl-OSType %exclude %{privlib}/Perl/OSType.pm %exclude %{_mandir}/man3/Perl::OSType.3pm* @@ -3443,6 +3528,39 @@ sed \ %{_mandir}/man3/Parse::CPAN::Meta.3* %endif +%files Perl4-CoreLibs +%{privlib}/abbrev.pl +%{privlib}/assert.pl +%{privlib}/bigfloat.pl +%{privlib}/bigint.pl +%{privlib}/bigrat.pl +%{privlib}/cacheout.pl +%{privlib}/complete.pl +%{privlib}/ctime.pl +%{privlib}/dotsh.pl +%{privlib}/exceptions.pl +%{privlib}/fastcwd.pl +%{privlib}/find.pl +%{privlib}/finddepth.pl +%{privlib}/flush.pl +%{privlib}/getcwd.pl +%{privlib}/getopt.pl +%{privlib}/getopts.pl +%{privlib}/hostname.pl +%{privlib}/importenv.pl +%{privlib}/look.pl +%{privlib}/newgetopt.pl +%{privlib}/open2.pl +%{privlib}/open3.pl +%{privlib}/pwd.pl +%{privlib}/shellwords.pl +%{privlib}/stat.pl +%{privlib}/syslog.pl +%{privlib}/tainted.pl +%{privlib}/termcap.pl +%{privlib}/timelocal.pl +%{privlib}/validate.pl + %if %{dual_life} || %{rebuild_from_scratch} %files parent %{privlib}/parent.pm @@ -3685,6 +3803,23 @@ sed \ # Old changelog entries are preserved in CVS. %changelog +* Wed Aug 17 2016 Jitka Plesnikova - 4:5.16.3-291 +- Backported and sub-packaged libraries historically supplied with Perl 4 + into perl-Perl4-CoreLibs + +* Tue Aug 16 2016 Jitka Plesnikova - 4:5.16.3-290 +- Removed deprecated files from provides (bug #1365991) + +* Mon Jun 13 2016 Petr Pisar - 4:5.16.3-289 +- Fix duplicating PerlIO::encoding when spawning threads (bug #1344749) + +* Wed Mar 02 2016 Jitka Plesnikova - 4:5.16.3-288 +- Fix CRLF conversion in ASCII FTP upload (bug #1263734) +- Don't leak the temp utf8 copy of namepv (bug #1063330) + +* Wed Mar 02 2016 Petr Šabata - 4:5.16.3-287 +- Make File::Glob work with threads again (bug #1223045) + * Thu Jul 02 2015 Petr Pisar - 4:5.16.3-286 - Remove CPU-speed-sensitive test in Benchmark test (bug #1238567) - Rebuild with corrected binutils to fix systemtap support (bug #1238472)