[p5sagit/p5-mst-13.2.git] / ext / List-Util / lib / Scalar / Util.pm

# Scalar::Util.pm
#
# Copyright (c) 1997-2006 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.

package Scalar::Util;

use strict;
use vars qw(@ISA @EXPORT_OK $VERSION);
require Exporter;
require List::Util; # List::Util loads the XS

@ISA       = qw(Exporter);
@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
$VERSION    = "1.19";
$VERSION   = eval $VERSION;

sub export_fail {
  if (grep { /^(weaken|isweak)$/ } @_ ) {
    require Carp;
    Carp::croak("Weak references are not implemented in the version of perl");
  }
  if (grep { /^(isvstring)$/ } @_ ) {
    require Carp;
    Carp::croak("Vstrings are not implemented in the version of perl");
  }
  if (grep { /^(dualvar|set_prototype)$/ } @_ ) {
    require Carp;
    Carp::croak("$1 is only avaliable with the XS version");
  }

  @_;
}

sub openhandle ($) {
  my $fh = shift;
  my $rt = reftype($fh) || '';

  return defined(fileno($fh)) ? $fh : undef
    if $rt eq 'IO';

  if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
    $fh = \(my $tmp=$fh);
  }
  elsif ($rt ne 'GLOB') {
    return undef;
  }

  (tied(*$fh) or defined(fileno($fh)))
    ? $fh : undef;
}

eval <<'ESQ' unless defined &dualvar;

use vars qw(@EXPORT_FAIL);
push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);

# The code beyond here is only used if the XS is not installed

# Hope nobody defines a sub by this name
sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }

sub blessed ($) {
  local($@, $SIG{__DIE__}, $SIG{__WARN__});
  length(ref($_[0]))
    ? eval { $_[0]->a_sub_not_likely_to_be_here }
    : undef
}

sub refaddr($) {
  my $pkg = ref($_[0]) or return undef;
  if (blessed($_[0])) {
    bless $_[0], 'Scalar::Util::Fake';
  }
  else {
    $pkg = undef;
  }
  "$_[0]" =~ /0x(\w+)/;
  my $i = do { local $^W; hex $1 };
  bless $_[0], $pkg if defined $pkg;
  $i;
}

sub reftype ($) {
  local($@, $SIG{__DIE__}, $SIG{__WARN__});
  my $r = shift;
  my $t;

  length($t = ref($r)) or return undef;

  # This eval will fail if the reference is not blessed
  eval { $r->a_sub_not_likely_to_be_here; 1 }
    ? do {
      $t = eval {
	  # we have a GLOB or an IO. Stringify a GLOB gives it's name
	  my $q = *$r;
	  $q =~ /^\*/ ? "GLOB" : "IO";
	}
	or do {
	  # OK, if we don't have a GLOB what parts of
	  # a glob will it populate.
	  # NOTE: A glob always has a SCALAR
	  local *glob = $r;
	  defined *glob{ARRAY} && "ARRAY"
	  or defined *glob{HASH} && "HASH"
	  or defined *glob{CODE} && "CODE"
	  or length(ref(${$r})) ? "REF" : "SCALAR";
	}
    }
    : $t
}

sub tainted {
  local($@, $SIG{__DIE__}, $SIG{__WARN__});
  local $^W = 0;
  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($_) or ref($_);
  return 1 if (/^[+-]?\d+$/); # is a +/- integer
  return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
  return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);

  0;
}

ESQ

1;

__END__

=head1 NAME

Scalar::Util - A selection of general-utility scalar subroutines

=head1 SYNOPSIS

    use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
                        weaken isvstring looks_like_number set_prototype);

=head1 DESCRIPTION

C<Scalar::Util> contains a selection of subroutines that people have
expressed would be nice to have in the perl core, but the usage would
not really be high enough to warrant the use of a keyword, and the size
so small such that being individual extensions would be wasteful.

By default C<Scalar::Util> does not export any subroutines. The
subroutines defined are

=over 4

=item blessed EXPR

If EXPR evaluates to a blessed reference the name of the package
that it is blessed into is returned. Otherwise C<undef> is returned.

   $scalar = "foo";
   $class  = blessed $scalar;           # undef

   $ref    = [];
   $class  = blessed $ref;              # undef

   $obj    = bless [], "Foo";
   $class  = blessed $obj;              # "Foo"

=item dualvar NUM, STRING

Returns a scalar that has the value NUM in a numeric context and the
value STRING in a string context.

    $foo = dualvar 10, "Hello";
    $num = $foo + 2;                    # 12
    $str = $foo . " world";             # Hello world

=item isvstring EXPR

If EXPR is a scalar which was coded as a vstring the result is true.

    $vs   = v49.46.48;
    $fmt  = isvstring($vs) ? "%vd" : "%s"; #true
    printf($fmt,$vs);

=item isweak EXPR

If EXPR is a scalar which is a weak reference the result is true.

    $ref  = \$foo;
    $weak = isweak($ref);               # false
    weaken($ref);
    $weak = isweak($ref);               # true

B<NOTE>: Copying a weak reference creates a normal, strong, reference.

    $copy = $ref;
    $weak = isweak($ref);               # false

=item looks_like_number EXPR

Returns true if perl thinks EXPR is a number. See
L<perlapi/looks_like_number>.

=item openhandle FH

Returns FH if FH may be used as a filehandle and is open, or FH is a tied
handle. Otherwise C<undef> is returned.

    $fh = openhandle(*STDIN);		# \*STDIN
    $fh = openhandle(\*STDIN);		# \*STDIN
    $fh = openhandle(*NOTOPEN);		# undef
    $fh = openhandle("scalar");		# undef
    
=item readonly SCALAR

Returns true if SCALAR is readonly.

    sub foo { readonly($_[0]) }

    $readonly = foo($bar);              # false
    $readonly = foo(0);                 # true

=item refaddr EXPR

If EXPR evaluates to a reference the internal memory address of
the referenced value is returned. Otherwise C<undef> is returned.

    $addr = refaddr "string";           # undef
    $addr = refaddr \$var;              # eg 12345678
    $addr = refaddr [];                 # eg 23456784

    $obj  = bless {}, "Foo";
    $addr = refaddr $obj;               # eg 88123488

=item reftype EXPR

If EXPR evaluates to a reference the type of the variable referenced
is returned. Otherwise C<undef> is returned.

    $type = reftype "string";           # undef
    $type = reftype \$var;              # SCALAR
    $type = reftype [];                 # ARRAY

    $obj  = bless {}, "Foo";
    $type = reftype $obj;               # HASH

=item set_prototype CODEREF, PROTOTYPE

Sets the prototype of the given function, or deletes it if PROTOTYPE is
undef. Returns the CODEREF.

    set_prototype \&foo, '$$';

=item tainted EXPR

Return true if the result of EXPR is tainted

    $taint = tainted("constant");       # false
    $taint = tainted($ENV{PWD});        # true if running under -T

=item weaken REF

REF will be turned into a weak reference. This means that it will not
hold a reference count on the object it references. Also when the reference
count on that object reaches zero, REF will be set to undef.

This is useful for keeping copies of references , but you don't want to
prevent the object being DESTROY-ed at its usual time.

    {
      my $var;
      $ref = \$var;
      weaken($ref);                     # Make $ref a weak reference
    }
    # $ref is now undef

Note that if you take a copy of a scalar with a weakened reference,
the copy will be a strong reference.

    my $var;
    my $foo = \$var;
    weaken($foo);                       # Make $foo a weak reference
    my $bar = $foo;                     # $bar is now a strong reference

This may be less obvious in other situations, such as C<grep()>, for instance
when grepping through a list of weakened references to objects that may have
been destroyed already:

    @object = grep { defined } @object;

This will indeed remove all references to destroyed objects, but the remaining
references to objects will be strong, causing the remaining objects to never
be destroyed because there is now always a strong reference to them in the
@object array.

=back

=head1 KNOWN BUGS

There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
show up as tests 8 and 9 of dualvar.t failing

=head1 SEE ALSO

L<List::Util>

=head1 COPYRIGHT

Copyright (c) 1997-2006 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.

Except weaken and isweak which are

Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.

=cut
Commit	Line	Data
f4a2945e	1	# Scalar::Util.pm
f4a2945e	2	#
ddf53ba4	3	# Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
f4a2945e	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
4984adac	9	use strict;
4984adac	10	use vars qw(@ISA @EXPORT_OK $VERSION);
f4a2945e	11	require Exporter;
	12	require List::Util; # List::Util loads the XS
	13
09c2a9b8	14	@ISA = qw(Exporter);
09c2a9b8	15	@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
ddf53ba4	16	$VERSION = "1.19";
09c2a9b8	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	}
f4a2945e	35
c0f790df	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
09c2a9b8	54	eval <<'ESQ' unless defined &dualvar;
09c2a9b8	55
4984adac	56	use vars qw(@EXPORT_FAIL);
09c2a9b8	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;
9850bf21	73	if (blessed($_[0])) {
	74	bless $_[0], 'Scalar::Util::Fake';
	75	}
	76	else {
	77	$pkg = undef;
	78	}
c658fda9	79	"$_[0]" =~ /0x(\w+)/;
c658fda9	80	my $i = do { local $^W; hex $1 };
9850bf21	81	bless $_[0], $pkg if defined $pkg;
09c2a9b8	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
4984adac	134	return 0 if !defined($_) or ref($_);
09c2a9b8	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
f4a2945e	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
4984adac	154	use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
4984adac	155	weaken isvstring looks_like_number set_prototype);
f4a2945e	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
c29e891d	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
f4a2945e	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";
c29e891d	189	$num = $foo + 2; # 12
c29e891d	190	$str = $foo . " world"; # Hello world
f4a2945e	191
60f3865b	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
f4a2945e	200	=item isweak EXPR
	201
	202	If EXPR is a scalar which is a weak reference the result is true.
	203
c29e891d	204	$ref = \$foo;
	205	$weak = isweak($ref); # false
	206	weaken($ref);
	207	$weak = isweak($ref); # true
	208
4984adac	209	B<NOTE>: Copying a weak reference creates a normal, strong, reference.
	210
	211	$copy = $ref;
	212	$weak = isweak($ref); # false
	213
9e7deb6c	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
c0f790df	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
ee4ffb48	229	=item readonly SCALAR
	230
	231	Returns true if SCALAR is readonly.
	232
c29e891d	233	sub foo { readonly($_[0]) }
	234
	235	$readonly = foo($bar); # false
	236	$readonly = foo(0); # true
	237
60f3865b	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
f4a2945e	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
c29e891d	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
97605c51	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
ee4ffb48	269	=item tainted EXPR
	270
	271	Return true if the result of EXPR is tainted
	272
c29e891d	273	$taint = tainted("constant"); # false
	274	$taint = tainted($ENV{PWD}); # true if running under -T
	275
f4a2945e	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
022735b4	283	prevent the object being DESTROY-ed at its usual time.
f4a2945e	284
c29e891d	285	{
	286	my $var;
	287	$ref = \$var;
	288	weaken($ref); # Make $ref a weak reference
	289	}
	290	# $ref is now undef
	291
cf083cf9	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
f4a2945e	311	=back
f4a2945e	312
9c3c560b	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
ddf53ba4	318	=head1 SEE ALSO
	319
	320	L<List::Util>
	321
f4a2945e	322	=head1 COPYRIGHT
f4a2945e	323
ddf53ba4	324	Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
c29e891d	325	This program is free software; you can redistribute it and/or modify it
f4a2945e	326	under the same terms as Perl itself.
f4a2945e	327
c29e891d	328	Except weaken and isweak which are
f4a2945e	329
	330	Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
	331	This program is free software; you can redistribute it and/or modify it
	332	under the same terms as perl itself.
	333
f4a2945e	334	=cut