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