/usr/share/perl5/perl5i/1/Meta/Instance.pm is in libperl5i-perl 2.8.0-1ubuntu1.
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 | package perl5i::1::Meta::Instance;
use strict;
use warnings;
require Scalar::Util;
require overload;
require Carp;
use perl5i::1::autobox;
use parent qw(perl5i::1::Meta);
sub class {
return ref ${$_[0]};
}
sub reftype {
return Scalar::Util::reftype(${$_[0]});
}
# Only instances can be tainted
# Returns the code which will run when the object is used as a string
my $has_string_overload = sub {
return overload::Method(${$_[0]}, q[""]) || overload::Method(${$_[0]}, q[0+])
};
sub is_tainted {
my $code;
if( $code = $_[0]->$has_string_overload ) {
require Taint::Util;
return Taint::Util::tainted( $code->(${$_[0]}) );
}
else {
return 0;
}
die "Never should be reached";
}
sub taint {
if( $_[0]->$has_string_overload ) {
Carp::croak "Untainted overloaded objects cannot normally be made tainted" if
!$_[0]->is_tainted;
return 1;
}
else {
Carp::croak "Only scalars can normally be made tainted";
}
Carp::confess "Should not be reached";
}
sub untaint {
if( $_[0]->$has_string_overload && $_[0]->is_tainted ) {
Carp::croak "Tainted overloaded objects cannot normally be untainted";
}
else {
return 1;
}
Carp::confess "Should never be reached";
}
sub checksum {
my( $thing, %args ) = @_;
my $algorithms = [qw(sha1 md5)];
$args{algorithm} //= 'sha1';
$args{algorithm} ~~ $algorithms or
Carp::croak("algorithm must be @{[ $algorithms->join(' or ' ) ]}");
my $algorithm2module = { sha1 => "Digest::SHA", md5 => "Digest::MD5" };
my $format = [qw(hex base64 binary)];
$args{format} //= 'hex';
$args{format} ~~ $format or
Carp::croak("format must be @{[ $format->join(' or ') ]}");
my %prefix = ( hex => 'hex', base64 => 'b64', binary => undef );
my $module = $algorithm2module->{ $args{algorithm} };
my $digest = defined $prefix{ $args{format} } ? $prefix{ $args{format} } . 'digest' : 'digest';
Module::Load::load($module);
my $digestor = $module->new;
require Data::Dumper;
my $d = Data::Dumper->new( [ ${$thing} ] );
$d->Deparse(1)->Terse(1)->Sortkeys(1)->Indent(0);
$digestor->add( $d->Dump );
return $digestor->$digest;
}
1;
|