← Back to branch summary

~ubuntu-branches/ubuntu/wily/libmodule-install-doapchangesets-perl/wily

« back to all changes in this revision

Viewing changes to inc/Scalar/Util/PP.pm

  • Committer: Package Import Robot
  • Author(s): Jonas Smedegaard
  • Date: 2012-06-04 16:00:32 UTC
  • Revision ID: package-import@ubuntu.com-20120604160032-o9fbat6slanxyjed
Tags: upstream-0.202
Import upstream version 0.202

Show diffs side-by-side

added added

removed removed

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