/usr/lib/perl5/Scalar/Util/PP.pm is in libscalar-list-utils-perl 1:1.23-1build2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | # Scalar::Util::PP.pm
#
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# This module is normally only loaded if the XS module is not available
package Scalar::Util::PP;
use strict;
use warnings;
use vars qw(@ISA @EXPORT $VERSION $recurse);
require Exporter;
use B qw(svref_2object);
@ISA = qw(Exporter);
@EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number);
$VERSION = "1.23";
$VERSION = eval $VERSION;
sub blessed ($) {
return undef unless length(ref($_[0]));
my $b = svref_2object($_[0]);
return undef unless $b->isa('B::PVMG');
my $s = $b->SvSTASH;
return $s->isa('B::HV') ? $s->NAME : undef;
}
sub refaddr($) {
return undef unless length(ref($_[0]));
my $addr;
if(defined(my $pkg = blessed($_[0]))) {
$addr .= bless $_[0], 'Scalar::Util::Fake';
bless $_[0], $pkg;
}
else {
$addr .= $_[0]
}
$addr =~ /0x(\w+)/;
local $^W;
no warnings 'portable';
hex($1);
}
{
my %tmap = qw(
B::NULL SCALAR
B::HV HASH
B::AV ARRAY
B::CV CODE
B::IO IO
B::GV GLOB
B::REGEXP REGEXP
);
sub reftype ($) {
my $r = shift;
return undef unless length(ref($r));
my $t = ref(svref_2object($r));
return
exists $tmap{$t} ? $tmap{$t}
: length(ref($$r)) ? 'REF'
: 'SCALAR';
}
}
sub tainted {
local($@, $SIG{__DIE__}, $SIG{__WARN__});
local $^W = 0;
no warnings;
eval { kill 0 * $_[0] };
$@ =~ /^Insecure/;
}
sub readonly {
return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
local($@, $SIG{__DIE__}, $SIG{__WARN__});
my $tmp = $_[0];
!eval { $_[0] = $tmp; 1 };
}
sub looks_like_number {
local $_ = shift;
# checks from perlfaq4
return 0 if !defined($_);
if (ref($_)) {
require overload;
return overload::Overloaded($_) ? defined(0 + $_) : 0;
}
return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
0;
}
1;
|