From: Jarkko Hietaniemi <jhi@iki.fi>
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<Data::Util> 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<Data::Util> 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<that know what they're doing.>
-
-The exact behavior exhibited by a piece of DATA when sv_readonly is
-set depends on what type of data it is.  B<It doesn't even necessarily
-make the data readonly!>  Look for specific functions in Scalar::Util,
-List::Util and Hash::Util for making those respective types readonly.
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern@pobox.com> using XS code by Nick Ing-Simmons.
-
-=head1 SEE ALSO
-
-L<Scalar::Util>, L<List::Util>, L<Hash::Util>
-
-=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;
+}
+