summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Scalar
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 17:57:31 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 17:57:31 +0000
commit320d8694fec25ed148613684543b5a0504a046ae (patch)
tree0ddcf933d3acd3c98a387fa2bf73d0554ca6e50d /Master/tlpkg/tlperl/lib/Scalar
parent779e71f16ca01a6244b632b95bdb461fec163b34 (diff)
New tlperl part XIV
git-svn-id: svn://tug.org/texlive/trunk@21436 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Scalar')
-rw-r--r--Master/tlpkg/tlperl/lib/Scalar/Util.pm283
-rw-r--r--Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm109
2 files changed, 392 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Scalar/Util.pm b/Master/tlpkg/tlperl/lib/Scalar/Util.pm
new file mode 100644
index 00000000000..24f146f2b3f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Scalar/Util.pm
@@ -0,0 +1,283 @@
+# Scalar::Util.pm
+#
+# Copyright (c) 1997-2007 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 @EXPORT_FAIL);
+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.22";
+$VERSION = eval $VERSION;
+
+unless (defined &dualvar) {
+ # Load Pure Perl version if XS not loaded
+ require Scalar::Util::PP;
+ Scalar::Util::PP->import;
+ push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
+}
+
+sub export_fail {
+ if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded
+ my $pat = join("|", @EXPORT_FAIL);
+ if (my ($err) = grep { /^($pat)$/ } @_ ) {
+ require Carp;
+ Carp::croak("$err is only available with the XS version of Scalar::Util");
+ }
+ }
+
+ 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");
+ }
+
+ @_;
+}
+
+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;
+}
+
+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);
+ # and other useful utils appearing below
+
+=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($copy); # 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 DIAGNOSTICS
+
+Module use may give one of the following errors during import.
+
+=over
+
+=item Weak references are not implemented in the version of perl
+
+The version of perl that you are using does not implement weak references, to use
+C<isweak> or C<weaken> you will need to use a newer release of perl.
+
+=item Vstrings are not implemented in the version of perl
+
+The version of perl that you are using does not implement Vstrings, to use
+C<isvstring> you will need to use a newer release of perl.
+
+=item C<NAME> is only available with the XS version of Scalar::Util
+
+C<Scalar::Util> contains both perl and C implementations of many of its functions
+so that those without access to a C compiler may still use it. However some of the functions
+are only available when a C compiler was available to compile the XS version of the extension.
+
+At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
+
+=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-2007 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
diff --git a/Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm b/Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm
new file mode 100644
index 00000000000..e94fe86f21c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm
@@ -0,0 +1,109 @@
+# Scalar::Util::PP.pm
+#
+# Copyright (c) 1997-2009 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.
+#
+# This module is normally only loaded if the XS module is not available
+
+package Scalar::Util::PP;
+
+use strict;
+use warnings;
+use vars qw(@ISA @EXPORT $VERSION $recurse);
+require Exporter;
+use B qw(svref_2object);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number);
+$VERSION = "1.22";
+$VERSION = eval $VERSION;
+
+sub blessed ($) {
+ return undef unless length(ref($_[0]));
+ my $b = svref_2object($_[0]);
+ return undef unless $b->isa('B::PVMG');
+ my $s = $b->SvSTASH;
+ return $s->isa('B::HV') ? $s->NAME : undef;
+}
+
+sub refaddr($) {
+ return undef unless length(ref($_[0]));
+
+ my $addr;
+ if(defined(my $pkg = blessed($_[0]))) {
+ $addr .= bless $_[0], 'Scalar::Util::Fake';
+ bless $_[0], $pkg;
+ }
+ else {
+ $addr .= $_[0]
+ }
+
+ $addr =~ /0x(\w+)/;
+ local $^W;
+ hex($1);
+}
+
+{
+ my %tmap = qw(
+ B::HV HASH
+ B::AV ARRAY
+ B::CV CODE
+ B::IO IO
+ B::NULL SCALAR
+ B::NV SCALAR
+ B::PV SCALAR
+ B::GV GLOB
+ B::RV REF
+ B::REGEXP REGEXP
+ );
+
+ sub reftype ($) {
+ my $r = shift;
+
+ return undef unless length(ref($r));
+
+ my $t = ref(svref_2object($r));
+
+ return
+ exists $tmap{$t} ? $tmap{$t}
+ : length(ref($$r)) ? 'REF'
+ : 'SCALAR';
+ }
+}
+
+sub tainted {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ no warnings;
+ 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($_);
+ if (ref($_)) {
+ require overload;
+ return overload::Overloaded($_) ? defined(0 + $_) : 0;
+ }
+ return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
+ return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
+ return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
+
+ 0;
+}
+
+
+1;