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

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

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.15";
$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;

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;
  bless $_[0], 'Scalar::Util::Fake';
  my $i = int($_[0]);
  bless $_[0], $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 $] < 5.009002 unless defined;
  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

=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 COPYRIGHT

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

=head1 BLATANT PLUG

The weaken and isweak subroutines in this module and the patch to the core Perl
were written in connection  with the APress book `Tuomas J. Lukka's Definitive
Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
things would have to be done in cumbersome ways.

=cut
Commit	Line	Data
f4a2945e	1	# Scalar::Util.pm
f4a2945e	2	#
cf083cf9	3	# Copyright (c) 1997-2005 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
	9	require Exporter;
	10	require List::Util; # List::Util loads the XS
	11
09c2a9b8	12	@ISA = qw(Exporter);
09c2a9b8	13	@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
cf083cf9	14	$VERSION = "1.15";
09c2a9b8	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	}
f4a2945e	33
c0f790df	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
09c2a9b8	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
4579700c	125	return $] < 5.009002 unless defined;
09c2a9b8	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
f4a2945e	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
97605c51	145	use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype);
f4a2945e	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
c29e891d	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
f4a2945e	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";
c29e891d	179	$num = $foo + 2; # 12
c29e891d	180	$str = $foo . " world"; # Hello world
f4a2945e	181
60f3865b	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
f4a2945e	190	=item isweak EXPR
	191
	192	If EXPR is a scalar which is a weak reference the result is true.
	193
c29e891d	194	$ref = \$foo;
	195	$weak = isweak($ref); # false
	196	weaken($ref);
	197	$weak = isweak($ref); # true
	198
9e7deb6c	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
c0f790df	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
ee4ffb48	214	=item readonly SCALAR
	215
	216	Returns true if SCALAR is readonly.
	217
c29e891d	218	sub foo { readonly($_[0]) }
	219
	220	$readonly = foo($bar); # false
	221	$readonly = foo(0); # true
	222
60f3865b	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
f4a2945e	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
c29e891d	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
97605c51	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
ee4ffb48	254	=item tainted EXPR
	255
	256	Return true if the result of EXPR is tainted
	257
c29e891d	258	$taint = tainted("constant"); # false
	259	$taint = tainted($ENV{PWD}); # true if running under -T
	260
f4a2945e	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
022735b4	268	prevent the object being DESTROY-ed at its usual time.
f4a2945e	269
c29e891d	270	{
	271	my $var;
	272	$ref = \$var;
	273	weaken($ref); # Make $ref a weak reference
	274	}
	275	# $ref is now undef
	276
cf083cf9	277	Note that if you take a copy of a scalar with a weakened reference,
	278	the copy will be a strong reference.
	279
	280	my $var;
	281	my $foo = \$var;
	282	weaken($foo); # Make $foo a weak reference
	283	my $bar = $foo; # $bar is now a strong reference
	284
	285	This may be less obvious in other situations, such as C<grep()>, for instance
	286	when grepping through a list of weakened references to objects that may have
	287	been destroyed already:
	288
	289	@object = grep { defined } @object;
	290
	291	This will indeed remove all references to destroyed objects, but the remaining
	292	references to objects will be strong, causing the remaining objects to never
	293	be destroyed because there is now always a strong reference to them in the
	294	@object array.
	295
f4a2945e	296	=back
f4a2945e	297
9c3c560b	298	=head1 KNOWN BUGS
	299
	300	There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
	301	show up as tests 8 and 9 of dualvar.t failing
	302
f4a2945e	303	=head1 COPYRIGHT
f4a2945e	304
cf083cf9	305	Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
c29e891d	306	This program is free software; you can redistribute it and/or modify it
f4a2945e	307	under the same terms as Perl itself.
f4a2945e	308
c29e891d	309	Except weaken and isweak which are
f4a2945e	310
	311	Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
	312	This program is free software; you can redistribute it and/or modify it
	313	under the same terms as perl itself.
	314
	315	=head1 BLATANT PLUG
	316
	317	The weaken and isweak subroutines in this module and the patch to the core Perl
	318	were written in connection with the APress book `Tuomas J. Lukka's Definitive
	319	Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
	320	things would have to be done in cumbersome ways.
	321
	322	=cut