[ 20362]
Upgrade to NEXT 0.52.
[ 20364]
Silence spurious noise from MakeMaker :
hint files shouldn't return undef and have set $!.
[ 20366]
Subject: [PATCH] test for B::Bytecode/ByteLoader
From: Enache Adrian <enache@rdslink.ro>
Date: Thu, 31 Jul 2003 03:49:40 +0300
Message-ID: <
20030731004940.GB1266@ratsnest.hole>
(but use test.pl:run_perl() instead of manual `$^X ...`)
[ 20367]
Subject: [PATCH Tie::RefHash] added support for overloaded ""
From: Xavier Noria <fxn@hashref.com>
Date: Thu, 31 Jul 2003 00:29:13 +0200
Message-Id: <
200307310029.13567.fxn@hashref.com>
[ 20368]
Tests for change #20367 (and change use overload; to
just require overload;)
[ 20369]
Final touches to "Apple-like" installation directories.
[ 20370]
Schwern says this is most probably an old VMS MakeMaker
bug workaround that can go now.
[ 20371]
ext/SDBM_File/sdbm's auto directory ended up in ext/SDBM_File.
(Schwern)
p4raw-link: @20371 on //depot/perl:
4644218255cda0e4e3e2d76588083cf8284a0cb2
p4raw-link: @20370 on //depot/perl:
e56d24debc8bcb8df9c55e541615965b9a93cd54
p4raw-link: @20369 on //depot/perl:
b69885a625fdcb7dccd41c0bfbeb615a164ff876
p4raw-link: @20368 on //depot/perl:
05d3035d05f97548c36b396e73ec38035eca6e8b
p4raw-link: @20367 on //depot/perl:
60ad8d7737ceae6f6c1fcd764c298b207f0f9a85
p4raw-link: @20366 on //depot/perl:
46983aadfac6b944b1ca63d7d2d411068cfd6b1c
p4raw-link: @20364 on //depot/perl:
6b60bc8c20f4a67591b13726b877b2e48fad78f6
p4raw-link: @20362 on //depot/perl:
52138ef3a06f8cb332cb62ae77832a62a0223d75
p4raw-id: //depot/maint-5.8/perl@20372
p4raw-branched: from //depot/perl@20365 'branch in' ext/B/t/bytecode.t
p4raw-integrated: from //depot/perl@20365 'copy in'
ext/DynaLoader/hints/linux.pl (@2620..) lib/Tie/RefHash.t
(@10676..) lib/NEXT/Changes lib/NEXT/README lib/NEXT/t/actuns.t
(@13117..) ext/SDBM_File/sdbm/Makefile.PL (@19116..)
lib/Tie/RefHash.pm (@19635..) lib/ExtUtils/MakeMaker.pm
(@20341..) lib/NEXT.pm lib/NEXT/t/unseen.t (@20348..) 'merge
in' MANIFEST (@20337..) hints/darwin.sh (@20353..)
ext/B/t/assembler.t See if B::Assembler, B::Disassembler comply
ext/B/t/b.t See if B works
ext/B/t/bblock.t See if B::Bblock works
+ext/B/t/bytecode.t See whether B::Bytecode works
ext/B/t/concise.t See whether B::Concise works
ext/B/t/debug.t See if B::Debug works
ext/B/t/deparse.t See if B::Deparse works
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(../lib);
+ require './test.pl'; # for run_perl()
+}
+use strict;
+
+my $test = 'bytecode.pl';
+END { 1 while unlink $test }
+
+undef $/;
+my @tests = split /\n###+\n/, <DATA>;
+
+print "1..".($#tests+1)."\n";
+
+my $cnt = 1;
+
+for (@tests) {
+ my $got;
+ my ($script, $expect) = split />>>+\n/;
+ $expect =~ s/\n$//;
+ open T, ">$test"; print T $script; close T;
+ $got = run_perl(switches => "-MO=Bytecode,-H,-o$test",
+ progfile => $test);
+ unless ($?) {
+ $got = run_perl(progfile => $test);
+ unless ($?) {
+ if ($got =~ /^$expect$/) {
+ print "ok $cnt\n";
+ next;
+ } else {
+ print <<"EOT"; next;
+not ok $cnt
+--------- SCRIPT
+$script
+--------- GOT
+$got
+--------- EXPECT
+$expect
+----------------
+
+EOT
+ }
+ }
+ }
+ print <<"EOT";
+--------- SCRIPT
+$script
+--------- $?
+$got
+EOT
+} continue {
+ $cnt++;
+}
+
+__DATA__
+
+print 'hi'
+>>>>
+hi
+############################################################
+for (1,2,3) { print if /\d/ }
+>>>>
+123
+############################################################
+$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
+>>>>
+zzz2y2y2
+############################################################
+$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
+>>>>
+z2y2y2
+############################################################
+split /a/,"bananarama"; print @_
+>>>>
+bnnrm
+############################################################
+{ package P; sub x { print 'ya' } x }
+>>>>
+ya
+############################################################
+@z = split /:/,"b:r:n:f:g"; print @z
+>>>>
+brnfg
+############################################################
+sub AUTOLOAD { print 1 } &{"a"}()
+>>>>
+1
+############################################################
+my $l = 3; $x = sub { print $l }; &$x
+>>>>
+3
+############################################################
+my $i = 1;
+my $foo = sub {$i = shift if @_};
+&$foo(3);
+############################################################
+print <.*>
+>>>>
+..*
+############################################################
+$_="\xff\xff"; use utf8; utf8::encode $_; print $_
+>>>>
+\xc3\xbf\xc3\xbf
+############################################################
+$x="Cannot use"; print index $x, "Can"
+>>>>
+0
+############################################################
+my $i=6; eval "print \$i\n"
+>>>>
+6
+############################################################
+BEGIN { %h=(1=>2,3=>4) } print $h{3}
+>>>>
+4
+############################################################
+open our $T,"a"
+############################################################
+print <DATA>
+__DATA__
+a
+b
+>>>>
+a
+b
+############################################################
+BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } }
+print $a[1]
+>>>>
+1
+############################################################
+my $i=3; print 1 .. $i
+>>>>
+123
+############################################################
+my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h
+>>>>
+ba
+############################################################
+print sort { my $p; $b <=> $a } 1,4,3
+>>>>
+431
# Some Linux releases like to hide their <nlist.h>
$self->{CCFLAGS} = $Config{ccflags} . ' -I/usr/include/libelf'
if -f "/usr/include/libelf/nlist.h";
+1;
# LINKTYPE => 'static',
DEFINE => $define,
INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's
- INST_ARCHLIB => '.',
SKIP => [qw(dynamic dynamic_lib dlsyms)],
OBJECT => '$(O_FILES)',
clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'},
prefix='/';
installprefix='/';
bin='/usr/bin';
- sitebin='/usr/bin';
+ siteprefix='/usr/local';
+ # We don't want /usr/bin/HEAD issues.
+ sitebin='/usr/local/bin';
+ sitescript='/usr/local/bin';
installusrbinperl='define'; # You knew what you were doing.
privlib="/System/Library/Perl/${version}";
sitelib="/Library/Perl/${version}";
# 4BSD uses ${prefix}/share/man, not ${prefix}/man.
man1dir='/usr/share/man/man1';
man3dir='/usr/share/man/man3';
+ # But users' installs shouldn't touch the system man pages.
+ installsiteman1='/usr/local/share/man/man1';
+ installsiteman3='/usr/local/share/man/man3';
;;
*) # Anything else; use non-system directories, use Configure defaults
;;
next unless defined $self->{PARENT}{$key};
# Don't stomp on WriteMakefile() args.
- $self->{$key} = $self->{PARENT}{$key}
- unless defined $self->{ARGS}{$key} and
- $self->{ARGS}{$key} eq $self->{$key};
+ next if defined $self->{ARGS}{$key} and
+ $self->{ARGS}{$key} eq $self->{$key};
+
+ $self->{$key} = $self->{PARENT}{$key};
unless ($Is_VMS && $key =~ /PERL$/) {
$self->{$key} = $self->catdir("..",$self->{$key})
package NEXT;
-$VERSION = '0.51';
+$VERSION = '0.52';
use Carp;
use strict;
-sub ancestors
+sub NEXT::ELSEWHERE::ancestors
{
my @inlist = shift;
my @outlist = ();
unless ($NEXT::NEXT{$self,$wanted_method}) {
my @forebears =
- ancestors ref $self || $self, $wanted_class;
+ NEXT::ELSEWHERE::ancestors ref $self || $self,
+ $wanted_class;
while (@forebears) {
last if shift @forebears eq $caller_class
}
@{$NEXT::NEXT{$self,$wanted_method}} =
map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
- $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
+ $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
}
my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
- while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
+ while ($wanted_class =~ /^NEXT:.*:(UNSEEN|DISTINCT):/ && defined $call_method
&& $NEXT::SEEN->{$self,$call_method}++) {
$call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
}
croak qq(Can't locate object method "$wanted_method" ),
qq(via package "$caller_class");
};
- return shift()->$call_method(@_) if ref $call_method eq 'CODE';
+ return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
no strict 'refs';
($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
if $wanted_method eq 'AUTOLOAD';
no strict 'vars';
package NEXT::UNSEEN; @ISA = 'NEXT';
+package NEXT::DISTINCT; @ISA = 'NEXT';
package NEXT::ACTUAL; @ISA = 'NEXT';
package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
+package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
+package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
+package EVERY; @ISA = 'NEXT';
1;
To cover such cases, you can redispatch methods via:
- $self->NEXT::UNSEEN::method();
+ $self->NEXT::DISTINCT::method();
rather than:
$self->NEXT::method();
-This causes the redispatcher to skip any classes in the hierarchy that it has
-already visited in an earlier redispatch. So, for example, if the
+This causes the redispatcher to only visit each distinct C<method> method
+once. That is, to skip any classes in the hierarchy that it has
+already visited during redispatch. So, for example, if the
previous example were rewritten:
package A;
- sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
+ sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
package B;
- sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
+ sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
package C; @ISA = qw( A );
- sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
+ sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
package D; @ISA = qw(A B);
- sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
+ sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
package E; @ISA = qw(C D);
- sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
+ sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
E->foo();
called D::foo
called B::foo
-and omit the second call to C<A::foo>.
+and omit the second call to C<A::foo> (since it would not be distinct
+from the first call to C<A::foo>).
Note that you can also use:
- $self->NEXT::UNSEEN::ACTUAL::method();
+ $self->NEXT::DISTINCT::ACTUAL::method();
or:
- $self->NEXT::ACTUAL::UNSEEN::method();
+ $self->NEXT::ACTUAL::DISTINCT::method();
to get both unique invocation I<and> exception-on-failure.
+Note that, for historical compatibility, you can also use
+C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
=head1 AUTHOR
consistent with more useful SUPER:: behaviour
- Corified tests
+
+
+0.51 Tue Jul 29 23:09:48 2003
+
+ - Fixed NEXT::UNSEEN bug under diamond inheritance (thanks Dan
+ and Alan)
+
+ - Moved &ancestors out of NEXT class in case anyone ever
+ calls NEXT::ancestors
+
+ - Replaced UNSEEN with DISTINCT (but left UNSEEN operational
+ for backwards compatibility)
+
+
+0.52 Wed Jul 30 21:06:59 2003
+
==============================================================================
- Release of version 0.50 of NEXT
+ Release of version 0.52 of NEXT
==============================================================================
the current class -- to look for a suitable method in other
ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.
- A particularly interesting use of redispatch is in
+ An particularly interesting use of redispatch is in
C<AUTOLOAD>'ed methods. If such a method determines that it is
not able to handle a particular call, it may choose to
redispatch that call, in the hope that some other C<AUTOLOAD>
==============================================================================
-CHANGES IN VERSION 0.50
+CHANGES IN VERSION 0.52
- - Added a $VERSION (oops!)
-
- - Fixed handling of diamond patterns (thanks Paul)
-
- - Added NEXT::ACTUAL to require existence of next method (thanks Paul)
-
- - Added NEXT::UNSEEN to avoid calling multiply inherited
- methods twice (thanks Paul)
-
- - Re-fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS to be
- consistent with more useful SUPER:: behaviour
-
- - Corified tests
==============================================================================
AVAILABILITY
NEXT has been uploaded to the CPAN
-and is also available from:
-
- http://www.csse.monash.edu.au/~damian/CPAN/NEXT.tar.gz
==============================================================================
}
}
-BEGIN { print "1..5\n"; }
+BEGIN { print "1..6\n"; }
use NEXT;
my $count=1;
bless($foo,"A");
eval { $foo->test } and print "not ";
-print "ok 5\n";
}
}
-BEGIN { print "1..5\n"; }
+BEGIN { print "1..10\n"; }
use NEXT;
my $count=1;
@ISA = qw(Tie::Hash);
use strict;
+require overload; # to support objects with overloaded ""
+
sub TIEHASH {
my $c = shift;
my $s = [];
sub FETCH {
my($s, $k) = @_;
if (ref $k) {
- if (defined $s->[0]{"$k"}) {
- $s->[0]{"$k"}[1];
+ my $kstr = overload::StrVal($k);
+ if (defined $s->[0]{$kstr}) {
+ $s->[0]{$kstr}[1];
}
else {
undef;
sub STORE {
my($s, $k, $v) = @_;
if (ref $k) {
- $s->[0]{"$k"} = [$k, $v];
+ $s->[0]{overload::StrVal($k)} = [$k, $v];
}
else {
$s->[1]{$k} = $v;
sub DELETE {
my($s, $k) = @_;
- (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k});
+ (ref $k) ? delete($s->[0]{overload::StrVal($k)}) : delete($s->[1]{$k});
}
sub EXISTS {
my($s, $k) = @_;
- (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k});
+ (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k});
}
sub FIRSTKEY {
my $s = shift;
keys %{$s->[0]}; # reset iterator
keys %{$s->[1]}; # reset iterator
- $s->[2] = 0;
+ $s->[2] = 0; # flag for iteration, see NEXTKEY
$s->NEXTKEY;
}
my ($k, $v);
if (!$s->[2]) {
if (($k, $v) = each %{$s->[0]}) {
- return $s->[0]{"$k"}[0];
+ return $v->[0];
}
else {
$s->[2] = 1;
use strict;
use Tie::RefHash;
use Data::Dumper;
-my $numtests = 34;
+my $numtests = 37;
my $currtest = 1;
print "1..$numtests\n";
my $ref = []; my $ref1 = [];
+package Boustrophedon; # A class with overloaded "".
+sub new { my ($c, $s) = @_; bless \$s, $c }
+use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
+package main;
+my $ox = Boustrophedon->new("foobar");
+
# Test standard hash functionality, by performing the same operations
# on a tied hash and on a normal hash, and checking that the results
# are the same. This does of course assume that Perl hashes are not
test(not exists($h{$ref}));
test((keys %h) == 0);
test((values %h) == 0);
+$h{$ox} = "bellow"; # overloaded ""
+test(exists $h{$ox});
+test($h{$ox} eq "bellow");
+test(not exists $h{"foobarraboof"});
undef $h;
untie %h;
https://perl5.git.perl.org / perl5.git / commitdiff