From: Jarkko Hietaniemi Date: Tue, 12 Mar 2002 15:41:23 +0000 (+0000) Subject: Move the readonly interface back to universal.c, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2956957731badfc3e16c029c1f22e4098fb8c46a;p=p5sagit%2Fp5-mst-13.2.git Move the readonly interface back to universal.c, (new name: Internals::SvREADONLY), remove Data::Util, move Hash::Util to lib, also introduce refcnt interface (Internals::SvREFCNT). Make both the new interfaces to be more sane so that if they set the value, they return the new value, not the old one. p4raw-id: //depot/perl@15201 --- diff --git a/MANIFEST b/MANIFEST index 5ba6957..3649958 100644 --- a/MANIFEST +++ b/MANIFEST @@ -127,13 +127,6 @@ ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer ext/Data/Dumper/t/dumper.t See if Data::Dumper works ext/Data/Dumper/t/overload.t See if Data::Dumper works for overloaded data ext/Data/Dumper/Todo Data pretty printer, futures -ext/Data/Util/Changes Data/Hash::Util, Change log -ext/Data/Util/Makefile.PL Data/Hash::Util, Makefile.PL -ext/Data/Util/Util.xs Data/Hash::Util, Data::Util XS code -ext/Data/Util/lib/Data/Util.pm Data/Hash::Util, Data::Util -ext/Data/Util/lib/Hash/Util.pm Data/Hash::Util, Hash::Util -ext/Data/Util/t/Data.t Data/Hash::Util, Data::Util test -ext/Data/Util/t/Hash.t Data/Hash::Util, Hash::Util test ext/DB_File/Changes Berkeley DB extension change log ext/DB_File/dbinfo Berkeley DB database version checker ext/DB_File/DB_File.pm Berkeley DB extension Perl module @@ -1087,6 +1080,8 @@ lib/Getopt/Std.t See if Getopt::Std and Getopt::Long work lib/getopts.pl Perl library supporting option parsing lib/h2ph.t See if h2ph works like it should lib/h2xs.t See if h2xs produces expected lists of files +lib/Hash/Util.pm Hash::Util +lib/Hash/Util.t See if Hash::Util works lib/hostname.pl Old hostname code lib/I18N/Collate.pm Routines to do strxfrm-based collation lib/I18N/Collate.t See if I18N::Collate works @@ -1100,6 +1095,7 @@ lib/if.t Tests for "use if" lib/importenv.pl Perl routine to get environment into variables lib/integer.pm For "use integer" lib/integer.t For "use integer" testing +lib/Internals.t For Internals::* testing lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open2.t See if IPC::Open2 works lib/IPC/Open3.pm Open a three-ended pipe! @@ -2064,8 +2060,8 @@ Porting/checkVERSION.pl Check whether we have $VERSIONs Porting/config.sh Sample config.sh Porting/config_H Sample config.h Porting/Contract Social contract for contributed modules in Perl core -Porting/findvars Find occurrences of words Porting/findrfuncs Find reentrant variants of functions used in an executable +Porting/findvars Find occurrences of words Porting/fixCORE Find and fix modules that generate warnings Porting/fixvars Find undeclared variables with C compiler and fix em Porting/genlog Generate formatted changelogs by querying p4d diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t index 9916521..9448425 100755 --- a/ext/B/t/stash.t +++ b/ext/B/t/stash.t @@ -66,7 +66,7 @@ print "# got = @got\n"; $got = "@got"; -my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy main utf8 warnings"; +my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals main utf8 warnings"; { no strict 'vars'; diff --git a/ext/Data/Util/Changes b/ext/Data/Util/Changes deleted file mode 100644 index f877d08..0000000 --- a/ext/Data/Util/Changes +++ /dev/null @@ -1,27 +0,0 @@ -0.04 Sun Mar 10 13:37:08 EST 2002 - * Bugs in the restricted hash implementation have been fixed. All - tests should pass on a perl sometime after about 15160 - * Minimum version is now 5.7.3 - - Changed diagnostic expecations to match new restricted hash - diagnostics. - -0.03 Sat Mar 9 20:11:00 EST 2002 - *** NOTE *** There are known failures in t/Hash.t. These are - due to bugs in perl's restricted hash implementation. They have - been left failing so Those That Know How To Fix It know where - the bugs are. - - * Data::Util::readonly() is now sv_readonly_flag() to make its - function less ambiguous. - * Hash::Util::lock_key/unlock_key is now lock_value/unlock_value - to make its functionality less ambiguous. It also takes - somewhat different arguments. - * Added lock_hash(), unlock_hash(). - -0.02 Wed Feb 27 23:35:58 EST 2002 - * lock_keys(%hash, @keys) implemented - * tarball name changed to the somewhat more proper Data-Hash-Utils - -0.01 Tue Feb 26 23:18:03 EST 2002 - - First released version - - There are some failures at the end of Hash.t diff --git a/ext/Data/Util/Makefile.PL b/ext/Data/Util/Makefile.PL deleted file mode 100644 index ef6bc3c..0000000 --- a/ext/Data/Util/Makefile.PL +++ /dev/null @@ -1,53 +0,0 @@ -# A template for Makefile.PL. -# - Set the $PACKAGE variable to the name of your module. -# - Set $LAST_API_CHANGE to reflect the last version you changed the API -# of your module. -# - Fill in your dependencies in PREREQ_PM -# Alternatively, you can say the hell with this and use h2xs. - -require 5.007003; - -use ExtUtils::MakeMaker; - -$PACKAGE = 'Data::Util'; -($PACKAGE_FILE = $PACKAGE) =~ s|::|/|g; -$LAST_API_CHANGE = 0.03; - -eval "require $PACKAGE"; - -unless ($@) { # Make sure we did find the module. - print <<"CHANGE_WARN" if ${$PACKAGE.'::VERSION'} < $LAST_API_CHANGE; - -NOTE: There have been API changes between this version and any older -than version $LAST_API_CHANGE! Please read the Changes file if you -are upgrading from a version older than $LAST_API_CHANGE. - -CHANGE_WARN -} - -WriteMakefile( - NAME => $PACKAGE, - DISTNAME => 'Data-Hash-Utils', - VERSION_FROM => "lib/$PACKAGE_FILE.pm", # finds $VERSION - PREREQ_PM => { }, -); - - -{ - package MY; - - sub test_via_harness { - my($self, $orig_perl, $tests) = @_; - - my @perls = ($orig_perl); - push @perls, qw(bleadperl) - if $ENV{PERL_TEST_ALL}; - - my $out; - foreach my $perl (@perls) { - $out .= $self->SUPER::test_via_harness($perl, $tests); - } - - return $out; - } -} diff --git a/ext/Data/Util/Util.xs b/ext/Data/Util/Util.xs deleted file mode 100644 index 6d246dd..0000000 --- a/ext/Data/Util/Util.xs +++ /dev/null @@ -1,29 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - - -MODULE=Data::Util PACKAGE=Data::Util - -int -sv_readonly_flag(...) -PROTOTYPE: \[$%@];$ -CODE: -{ - SV *sv = SvRV(ST(0)); - IV old = SvREADONLY(sv); - - if (items == 2) { - if (SvTRUE(ST(1))) { - SvREADONLY_on(sv); - } - else { - SvREADONLY_off(sv); - } - } - if (old) - XSRETURN_YES; - else - XSRETURN_NO; -} - diff --git a/ext/Data/Util/lib/Data/Util.pm b/ext/Data/Util/lib/Data/Util.pm deleted file mode 100644 index 26e2993..0000000 --- a/ext/Data/Util/lib/Data/Util.pm +++ /dev/null @@ -1,73 +0,0 @@ -package Data::Util; - -require Exporter; -require DynaLoader; - -our @ISA = qw(Exporter DynaLoader); -our @EXPORT_OK = qw(sv_readonly_flag); -our $VERSION = 0.04; - -bootstrap Data::Util $VERSION; - -1; - -__END__ - -=head1 NAME - -Data::Util - A selection of general-utility data subroutines - -=head1 SYNOPSIS - - use Data::Util qw(sv_readonly_flag); - - my $sv_readonly = sv_readonly_flag(%some_data); - - sv_readonly_flag(@some_data, 1); # Set the sv_readonly flag on - # @some_data to true. - -=head1 DESCRIPTION - -C contains a selection of subroutines which are useful on -scalars, hashes and lists (and thus wouldn't fit into Scalar, Hash or -List::Util). All of the routines herein will work equally well on a -scalar, hash, list or even hash & list elements. - - sv_readonly_flag($some_data); - sv_readonly_flag(@some_data); - sv_readonly_flag(%some_data); - sv_readonly_flag($some_data{key}); - sv_readonly_flag($some_data[3]); - -We'll just refer to the conglomeration as "DATA". - -By default C does not export any subroutines. You can ask -for... - -=over 4 - -=item sv_readonly_flag - - my $sv_readonly = sv_readonly_flag(DATA); - sv_readonly_flag(DATA, 1); # set sv_readonly true - sv_readonly_flag(DATA, 0); # set sv_readonly false - -This gets/sets the sv_readonly flag on the given DATA. When setting -it returns the previous state of the flag. This is intended for -people I - -The exact behavior exhibited by a piece of DATA when sv_readonly is -set depends on what type of data it is. B Look for specific functions in Scalar::Util, -List::Util and Hash::Util for making those respective types readonly. - -=head1 AUTHOR - -Michael G Schwern using XS code by Nick Ing-Simmons. - -=head1 SEE ALSO - -L, L, L - -=cut - diff --git a/ext/Data/Util/t/Data.t b/ext/Data/Util/t/Data.t deleted file mode 100644 index 6198c3a..0000000 --- a/ext/Data/Util/t/Data.t +++ /dev/null @@ -1,42 +0,0 @@ -#!/usr/bin/perl -Tw - -BEGIN { - if( $ENV{PERL_CORE} ) { - @INC = '../lib'; - chdir 't'; - } -} -use Test::More tests => 26; - -use Data::Util; -BEGIN { use_ok 'Data::Util', qw(sv_readonly_flag); } - -ok( !sv_readonly_flag $foo ); -ok( !sv_readonly_flag $foo, 1 ); -ok( sv_readonly_flag $foo ); -ok( sv_readonly_flag $foo, 0 ); -ok( !sv_readonly_flag $foo ); - -ok( !sv_readonly_flag @foo ); -ok( !sv_readonly_flag @foo, 1 ); -ok( sv_readonly_flag @foo ); -ok( sv_readonly_flag @foo, 0 ); -ok( !sv_readonly_flag @foo ); - -ok( !sv_readonly_flag $foo[2] ); -ok( !sv_readonly_flag $foo[2], 1 ); -ok( sv_readonly_flag $foo[2] ); -ok( sv_readonly_flag $foo[2], 0 ); -ok( !sv_readonly_flag $foo[2] ); - -ok( !sv_readonly_flag %foo ); -ok( !sv_readonly_flag %foo, 1 ); -ok( sv_readonly_flag %foo ); -ok( sv_readonly_flag %foo, 0 ); -ok( !sv_readonly_flag %foo ); - -ok( !sv_readonly_flag $foo{foo} ); -ok( !sv_readonly_flag $foo{foo}, 1 ); -ok( sv_readonly_flag $foo{foo} ); -ok( sv_readonly_flag $foo{foo}, 0 ); -ok( !sv_readonly_flag $foo{foo} ); diff --git a/ext/Data/Util/lib/Hash/Util.pm b/lib/Hash/Util.pm similarity index 93% rename from ext/Data/Util/lib/Hash/Util.pm rename to lib/Hash/Util.pm index c54fbdc..f6fed97 100644 --- a/ext/Data/Util/lib/Hash/Util.pm +++ b/lib/Hash/Util.pm @@ -2,7 +2,6 @@ package Hash::Util; require 5.007003; use strict; -use Data::Util qw(sv_readonly_flag); use Carp; require Exporter; @@ -87,14 +86,14 @@ sub lock_keys (\%;@) { foreach my $k (@keys) { $hash->{$k} = undef unless exists $hash->{$k}; } - sv_readonly_flag %$hash, 1; + Internals::SvREADONLY %$hash, 1; foreach my $k (@keys) { delete $hash->{$k} unless $original_keys{$k}; } } else { - sv_readonly_flag %$hash, 1; + Internals::SvREADONLY %$hash, 1; } return undef; @@ -103,7 +102,7 @@ sub lock_keys (\%;@) { sub unlock_keys (\%) { my($hash) = shift; - sv_readonly_flag %$hash, 0; + Internals::SvREADONLY %$hash, 0; return undef; } @@ -124,13 +123,13 @@ key cannot be changed. sub lock_value (\%$) { my($hash, $key) = @_; carp "Cannot usefully lock values in an unlocked hash" - unless sv_readonly_flag %$hash; - sv_readonly_flag $hash->{$key}, 1; + unless Internals::SvREADONLY %$hash; + Internals::SvREADONLY $hash->{$key}, 1; } sub unlock_value (\%$) { my($hash, $key) = @_; - sv_readonly_flag $hash->{$key}, 0; + Internals::SvREADONLY $hash->{$key}, 0; } diff --git a/ext/Data/Util/t/Hash.t b/lib/Hash/Util.t similarity index 94% rename from ext/Data/Util/t/Hash.t rename to lib/Hash/Util.t index b1f9e79..0fe3128 100644 --- a/ext/Data/Util/t/Hash.t +++ b/lib/Hash/Util.t @@ -7,7 +7,6 @@ BEGIN { } } use Test::More tests => 45; -use Data::Util qw(sv_readonly_flag); my @Exported_Funcs; BEGIN { @@ -154,15 +153,15 @@ TODO: { my %hash = (foo => 42, bar => 23); lock_hash( %hash ); - ok( sv_readonly_flag(%hash) ); - ok( sv_readonly_flag($hash{foo}) ); - ok( sv_readonly_flag($hash{bar}) ); + ok( Internals::SvREADONLY(%hash) ); + ok( Internals::SvREADONLY($hash{foo}) ); + ok( Internals::SvREADONLY($hash{bar}) ); unlock_hash ( %hash ); - ok( !sv_readonly_flag(%hash) ); - ok( !sv_readonly_flag($hash{foo}) ); - ok( !sv_readonly_flag($hash{bar}) ); + ok( !Internals::SvREADONLY(%hash) ); + ok( !Internals::SvREADONLY($hash{foo}) ); + ok( !Internals::SvREADONLY($hash{bar}) ); } diff --git a/lib/Internals.t b/lib/Internals.t new file mode 100644 index 0000000..1f514fd --- /dev/null +++ b/lib/Internals.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl -Tw + +BEGIN { + if( $ENV{PERL_CORE} ) { + @INC = '../lib'; + chdir 't'; + } +} + +use Test::More tests => 29; + +my $foo; + +ok( !Internals::SvREADONLY $foo ); +ok( Internals::SvREADONLY $foo, 1 ); +ok( Internals::SvREADONLY $foo ); +ok( !Internals::SvREADONLY $foo, 0 ); +ok( !Internals::SvREADONLY $foo ); + +ok( !Internals::SvREADONLY @foo ); +ok( Internals::SvREADONLY @foo, 1 ); +ok( Internals::SvREADONLY @foo ); +ok( !Internals::SvREADONLY @foo, 0 ); +ok( !Internals::SvREADONLY @foo ); + +ok( !Internals::SvREADONLY $foo[2] ); +ok( Internals::SvREADONLY $foo[2], 1 ); +ok( Internals::SvREADONLY $foo[2] ); +ok( !Internals::SvREADONLY $foo[2], 0 ); +ok( !Internals::SvREADONLY $foo[2] ); + +ok( !Internals::SvREADONLY %foo ); +ok( Internals::SvREADONLY %foo, 1 ); +ok( Internals::SvREADONLY %foo ); +ok( !Internals::SvREADONLY %foo, 0 ); +ok( !Internals::SvREADONLY %foo ); + +ok( !Internals::SvREADONLY $foo{foo} ); +ok( Internals::SvREADONLY $foo{foo}, 1 ); +ok( Internals::SvREADONLY $foo{foo} ); +ok( !Internals::SvREADONLY $foo{foo}, 0 ); +ok( !Internals::SvREADONLY $foo{foo} ); + +is( Internals::SvREFCNT($foo), 1 ); +{ + my $bar = \$foo; + is( Internals::SvREFCNT($foo), 2 ); + is( Internals::SvREFCNT($bar), 1 ); +} +is( Internals::SvREFCNT($foo), 1 ); + diff --git a/universal.c b/universal.c index ae12e27..16000f7 100644 --- a/universal.c +++ b/universal.c @@ -167,6 +167,8 @@ XS(XS_utf8_upgrade); XS(XS_utf8_downgrade); XS(XS_utf8_unicode_to_native); XS(XS_utf8_native_to_unicode); +XS(XS_Internals_SvREADONLY); +XS(XS_Internals_SvREFCNT); void Perl_boot_core_UNIVERSAL(pTHX) @@ -183,6 +185,8 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("utf8::downgrade", XS_utf8_downgrade, file); newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); + newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); + newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); } @@ -458,3 +462,39 @@ XS(XS_utf8_unicode_to_native) XSRETURN(1); } +XS(XS_Internals_SvREADONLY) +{ + dXSARGS; + SV *sv = SvRV(ST(0)); + if (items == 1) { + if (SvREADONLY(sv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + else if (items == 2) { + if (SvTRUE(ST(1))) { + SvREADONLY_on(sv); + XSRETURN_YES; + } + else { + SvREADONLY_off(sv); + XSRETURN_NO; + } + } + XSRETURN_UNDEF; +} + +XS(XS_Internals_SvREFCNT) +{ + dXSARGS; + SV *sv = SvRV(ST(0)); + if (items == 1) + XSRETURN_IV(SvREFCNT(sv) - 1); /* minus the SvRV above */ + else if (items == 2) { + SvREFCNT(sv) = SvIV(ST(1)); + XSRETURN_IV(SvREFCNT(sv)); + } + XSRETURN_UNDEF; +} +