home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Scalar / Util.pm
Text File  |  2006-11-29  |  8KB  |  304 lines
  1. # Scalar::Util.pm
  2. #
  3. # Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package Scalar::Util;
  8.  
  9. require Exporter;
  10. require List::Util; # List::Util loads the XS
  11.  
  12. @ISA       = qw(Exporter);
  13. @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
  14. $VERSION    = "1.14";
  15. $VERSION   = eval $VERSION;
  16.  
  17. sub export_fail {
  18.   if (grep { /^(weaken|isweak)$/ } @_ ) {
  19.     require Carp;
  20.     Carp::croak("Weak references are not implemented in the version of perl");
  21.   }
  22.   if (grep { /^(isvstring)$/ } @_ ) {
  23.     require Carp;
  24.     Carp::croak("Vstrings are not implemented in the version of perl");
  25.   }
  26.   if (grep { /^(dualvar|set_prototype)$/ } @_ ) {
  27.     require Carp;
  28.     Carp::croak("$1 is only avaliable with the XS version");
  29.   }
  30.  
  31.   @_;
  32. }
  33.  
  34. sub openhandle ($) {
  35.   my $fh = shift;
  36.   my $rt = reftype($fh) || '';
  37.  
  38.   return defined(fileno($fh)) ? $fh : undef
  39.     if $rt eq 'IO';
  40.  
  41.   if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
  42.     $fh = \(my $tmp=$fh);
  43.   }
  44.   elsif ($rt ne 'GLOB') {
  45.     return undef;
  46.   }
  47.  
  48.   (tied(*$fh) or defined(fileno($fh)))
  49.     ? $fh : undef;
  50. }
  51.  
  52. eval <<'ESQ' unless defined &dualvar;
  53.  
  54. push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
  55.  
  56. # The code beyond here is only used if the XS is not installed
  57.  
  58. # Hope nobody defines a sub by this name
  59. sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
  60.  
  61. sub blessed ($) {
  62.   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  63.   length(ref($_[0]))
  64.     ? eval { $_[0]->a_sub_not_likely_to_be_here }
  65.     : undef
  66. }
  67.  
  68. sub refaddr($) {
  69.   my $pkg = ref($_[0]) or return undef;
  70.   bless $_[0], 'Scalar::Util::Fake';
  71.   my $i = int($_[0]);
  72.   bless $_[0], $pkg;
  73.   $i;
  74. }
  75.  
  76. sub reftype ($) {
  77.   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  78.   my $r = shift;
  79.   my $t;
  80.  
  81.   length($t = ref($r)) or return undef;
  82.  
  83.   # This eval will fail if the reference is not blessed
  84.   eval { $r->a_sub_not_likely_to_be_here; 1 }
  85.     ? do {
  86.       $t = eval {
  87.       # we have a GLOB or an IO. Stringify a GLOB gives it's name
  88.       my $q = *$r;
  89.       $q =~ /^\*/ ? "GLOB" : "IO";
  90.     }
  91.     or do {
  92.       # OK, if we don't have a GLOB what parts of
  93.       # a glob will it populate.
  94.       # NOTE: A glob always has a SCALAR
  95.       local *glob = $r;
  96.       defined *glob{ARRAY} && "ARRAY"
  97.       or defined *glob{HASH} && "HASH"
  98.       or defined *glob{CODE} && "CODE"
  99.       or length(ref(${$r})) ? "REF" : "SCALAR";
  100.     }
  101.     }
  102.     : $t
  103. }
  104.  
  105. sub tainted {
  106.   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  107.   local $^W = 0;
  108.   eval { kill 0 * $_[0] };
  109.   $@ =~ /^Insecure/;
  110. }
  111.  
  112. sub readonly {
  113.   return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
  114.  
  115.   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  116.   my $tmp = $_[0];
  117.  
  118.   !eval { $_[0] = $tmp; 1 };
  119. }
  120.  
  121. sub looks_like_number {
  122.   local $_ = shift;
  123.  
  124.   # checks from perlfaq4
  125.   return $] < 5.009002 unless defined;
  126.   return 1 if (/^[+-]?\d+$/); # is a +/- integer
  127.   return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
  128.   return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
  129.  
  130.   0;
  131. }
  132.  
  133. ESQ
  134.  
  135. 1;
  136.  
  137. __END__
  138.  
  139. =head1 NAME
  140.  
  141. Scalar::Util - A selection of general-utility scalar subroutines
  142.  
  143. =head1 SYNOPSIS
  144.  
  145.     use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype);
  146.  
  147. =head1 DESCRIPTION
  148.  
  149. C<Scalar::Util> contains a selection of subroutines that people have
  150. expressed would be nice to have in the perl core, but the usage would
  151. not really be high enough to warrant the use of a keyword, and the size
  152. so small such that being individual extensions would be wasteful.
  153.  
  154. By default C<Scalar::Util> does not export any subroutines. The
  155. subroutines defined are
  156.  
  157. =over 4
  158.  
  159. =item blessed EXPR
  160.  
  161. If EXPR evaluates to a blessed reference the name of the package
  162. that it is blessed into is returned. Otherwise C<undef> is returned.
  163.  
  164.    $scalar = "foo";
  165.    $class  = blessed $scalar;           # undef
  166.  
  167.    $ref    = [];
  168.    $class  = blessed $ref;              # undef
  169.  
  170.    $obj    = bless [], "Foo";
  171.    $class  = blessed $obj;              # "Foo"
  172.  
  173. =item dualvar NUM, STRING
  174.  
  175. Returns a scalar that has the value NUM in a numeric context and the
  176. value STRING in a string context.
  177.  
  178.     $foo = dualvar 10, "Hello";
  179.     $num = $foo + 2;                    # 12
  180.     $str = $foo . " world";             # Hello world
  181.  
  182. =item isvstring EXPR
  183.  
  184. If EXPR is a scalar which was coded as a vstring the result is true.
  185.  
  186.     $vs   = v49.46.48;
  187.     $fmt  = isvstring($vs) ? "%vd" : "%s"; #true
  188.     printf($fmt,$vs);
  189.  
  190. =item isweak EXPR
  191.  
  192. If EXPR is a scalar which is a weak reference the result is true.
  193.  
  194.     $ref  = \$foo;
  195.     $weak = isweak($ref);               # false
  196.     weaken($ref);
  197.     $weak = isweak($ref);               # true
  198.  
  199. =item looks_like_number EXPR
  200.  
  201. Returns true if perl thinks EXPR is a number. See
  202. L<perlapi/looks_like_number>.
  203.  
  204. =item openhandle FH
  205.  
  206. Returns FH if FH may be used as a filehandle and is open, or FH is a tied
  207. handle. Otherwise C<undef> is returned.
  208.  
  209.     $fh = openhandle(*STDIN);        # \*STDIN
  210.     $fh = openhandle(\*STDIN);        # \*STDIN
  211.     $fh = openhandle(*NOTOPEN);        # undef
  212.     $fh = openhandle("scalar");        # undef
  213.     
  214. =item readonly SCALAR
  215.  
  216. Returns true if SCALAR is readonly.
  217.  
  218.     sub foo { readonly($_[0]) }
  219.  
  220.     $readonly = foo($bar);              # false
  221.     $readonly = foo(0);                 # true
  222.  
  223. =item refaddr EXPR
  224.  
  225. If EXPR evaluates to a reference the internal memory address of
  226. the referenced value is returned. Otherwise C<undef> is returned.
  227.  
  228.     $addr = refaddr "string";           # undef
  229.     $addr = refaddr \$var;              # eg 12345678
  230.     $addr = refaddr [];                 # eg 23456784
  231.  
  232.     $obj  = bless {}, "Foo";
  233.     $addr = refaddr $obj;               # eg 88123488
  234.  
  235. =item reftype EXPR
  236.  
  237. If EXPR evaluates to a reference the type of the variable referenced
  238. is returned. Otherwise C<undef> is returned.
  239.  
  240.     $type = reftype "string";           # undef
  241.     $type = reftype \$var;              # SCALAR
  242.     $type = reftype [];                 # ARRAY
  243.  
  244.     $obj  = bless {}, "Foo";
  245.     $type = reftype $obj;               # HASH
  246.  
  247. =item set_prototype CODEREF, PROTOTYPE
  248.  
  249. Sets the prototype of the given function, or deletes it if PROTOTYPE is
  250. undef. Returns the CODEREF.
  251.  
  252.     set_prototype \&foo, '$$';
  253.  
  254. =item tainted EXPR
  255.  
  256. Return true if the result of EXPR is tainted
  257.  
  258.     $taint = tainted("constant");       # false
  259.     $taint = tainted($ENV{PWD});        # true if running under -T
  260.  
  261. =item weaken REF
  262.  
  263. REF will be turned into a weak reference. This means that it will not
  264. hold a reference count on the object it references. Also when the reference
  265. count on that object reaches zero, REF will be set to undef.
  266.  
  267. This is useful for keeping copies of references , but you don't want to
  268. prevent the object being DESTROY-ed at its usual time.
  269.  
  270.     {
  271.       my $var;
  272.       $ref = \$var;
  273.       weaken($ref);                     # Make $ref a weak reference
  274.     }
  275.     # $ref is now undef
  276.  
  277. =back
  278.  
  279. =head1 KNOWN BUGS
  280.  
  281. There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
  282. show up as tests 8 and 9 of dualvar.t failing
  283.  
  284. =head1 COPYRIGHT
  285.  
  286. Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
  287. This program is free software; you can redistribute it and/or modify it
  288. under the same terms as Perl itself.
  289.  
  290. Except weaken and isweak which are
  291.  
  292. Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
  293. This program is free software; you can redistribute it and/or modify it
  294. under the same terms as perl itself.
  295.  
  296. =head1 BLATANT PLUG
  297.  
  298. The weaken and isweak subroutines in this module and the patch to the core Perl
  299. were written in connection  with the APress book `Tuomas J. Lukka's Definitive
  300. Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
  301. things would have to be done in cumbersome ways.
  302.  
  303. =cut
  304.