[OpenSPARC-T2-SAM] / sam-t2 / devtools / v9 / lib / perl5 / 5.8.8 / 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;

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.18";
$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 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
920dae64 AT	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