use XSLoader ();
require Exporter;
@ISA = qw(Exporter);
+
+# walkoptree comes from B.pm (you are there), walkoptree comes from B.xs
@EXPORT_OK = qw(minus_c ppname save_BEGINs
class peekop cast_I32 cstring cchar hash threadsv_names
- main_root main_start main_cv svref_2object opnumber amagic_generation
+ main_root main_start main_cv svref_2object opnumber
+ amagic_generation
walkoptree_slow walkoptree walkoptree_exec walksymtable
parents comppadlist sv_undef compile_stats timing_info
begin_av init_av end_av);
+
sub OPf_KIDS ();
use strict;
@B::SV::ISA = 'B::OBJECT';
return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
}
-sub walkoptree {
+sub walkoptree_slow {
my($op, $method, $level) = @_;
$op_count++; # just for statistics
$level ||= 0;
my $kid;
unshift(@parents, $op);
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
- walkoptree($kid, $method, $level + 1);
+ walkoptree_slow($kid, $method, $level + 1);
}
shift @parents;
}
}
-*walkoptree_slow = \&walkoptree; # Who is using this?
-
sub compile_stats {
return "Total number of OPs processed: $op_count\n";
}
my $state = $kid->first;
my $cuddle = $self->{'cuddle'};
my($expr, @exprs);
- for (; $$state != $$cont; $state = $state->sibling) {
+ for (; $$state != $$cont and can $state "sibling"; $state = $state->sibling) {
$expr = "";
if (is_state $state) {
$expr = $self->deparse($state, 0);
push @exprs, $expr if $expr;
}
$kid = join(";\n", @exprs);
+ if (class($cont) eq "LISTOP") {
$cont = $cuddle . "continue {\n\t" .
$self->deparse($cont, 0) . "\n\b}\cK";
+ } else {
+ $cont = "\cK";
+ }
} else {
$cont = "\cK";
$kid = $self->deparse($kid, 0);
-x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid;
-f 't/rantests' || $Is_W32
- || warn "WARNING: You've never run 'make test'!!!",
- " (Installing anyway.)\n";
+ || warn "WARNING: You've never run 'make test' or",
+ " some tests failed! (Installing anyway.)\n";
if ($Is_W32 or $Is_Cygwin) {
my $perldll;
$OS = $Config::Config{'osname'};
}
}
-if ($OS=~/Win/i) {
+if ($OS =~ /^MSWin/i) {
$OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
+} elsif ($OS =~ /^VMS/i) {
$OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
- $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
+} elsif ($OS =~ /^dos/i) {
$OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
+} elsif ($OS =~ /^MacOS/i) {
$OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
$OS = 'OS2';
-} elsif ($OS=~/epoc/) {
+} elsif ($OS =~ /^epoc/i) {
$OS = 'EPOC';
} else {
$OS = 'UNIX';
$self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
my $perl_h;
+ no warnings 'uninitialized' ;
if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
and not $old){
# Maybe somebody tries to build an extension with an
=item MAN3PODS
-Hashref of .pm and .pod files. MakeMaker will default this to all
- .pod and any .pm files that include POD directives. The files listed
-here will be converted to man pages and installed as was requested
-at Configure time.
+Hashref that assigns to *.pm and *.pod files the files into which the
+manpages are to be written. MakeMaker parses all *.pod and *.pm files
+for POD directives. Files that contain POD will be the default keys of
+the MAN3PODS hashref. These will then be converted to man pages during
+C<make> and will be installed during C<make install>.
=item MAP_TARGET
(F) The '!' is allowed in pack() and unpack() only after certain types.
See L<perlfunc/pack>.
-=item Ambiguous -%c() resolved as a file test
-
-(W ambiguous) You used a "-" right in front a call to a subroutine
-that has the same name as a Perl file test (C<r w x o R W X O e z s
-f d l p S u g k b c t T B M A C>).
-
-To disambiguate it as a subroutine call, use either an extra space after
-the "-", C<- f(...)>, or an extra set of parentheses, C<-(f(...))>.
-To disambiguate it as a file test, use an extra space after the operator
-name C<-f (...)>, or add the space and remove the parentheses, C<-f ...>.
-
=item Ambiguous call resolved as CORE::%s(), qualify as such or use &
(W ambiguous) A subroutine you have declared has the same name as a Perl
Binary "<=>" returns -1, 0, or 1 depending on whether the left
argument is numerically less than, equal to, or greater than the right
argument. If your platform supports NaNs (not-a-numbers) as numeric
-values, using them with "<=>" (or any other numeric comparison)
-returns undef.
+values, using them with "<=>" returns undef. NaN is not "<", "==", ">",
+"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN
+returns true, as does NaN != anything else. If your platform doesn't
+support NaNs then NaN is just a string with numeric value 0.
+
+ perl -le '$a = NaN; print "No NaN support here" if $a == $a'
+ perl -le '$a = NaN; print "NaN support here" if $a != $a'
Binary "eq" returns true if the left argument is stringwise equal to
the right argument.
while (++MARK <= SP) {
SV *keysv = *MARK;
SV **svp;
+ I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
if (realhv) {
HE *he = hv_fetch_ent(hv, keysv, lval, 0);
svp = he ? &HeVAL(he) : 0;
STRLEN n_a;
DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
}
- if (PL_op->op_private & OPpLVAL_INTRO)
- save_helem(hv, keysv, svp);
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (preeminent)
+ save_helem(hv, keysv, svp);
+ else {
+ STRLEN keylen;
+ char *key = SvPV(keysv, keylen);
+ save_delete(hv, key, keylen);
+ }
+ }
}
*MARK = svp ? *svp : &PL_sv_undef;
}
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+ I32 preeminent;
if (SvTYPE(hv) == SVt_PVHV) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : 0;
}
if (PL_op->op_private & OPpLVAL_INTRO) {
if (HvNAME(hv) && isGV(*svp))
save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
- else
- save_helem(hv, keysv, svp);
+ else {
+ if (!preeminent) {
+ STRLEN keylen;
+ char *key = SvPV(keysv, keylen);
+ save_delete(hv, key, keylen);
+ } else
+ save_helem(hv, keysv, svp);
+ }
}
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
ptr = SSPOPPTR;
(void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
SvREFCNT_dec(hv);
- Safefree(ptr);
break;
case SAVEt_DESTRUCTOR:
ptr = SSPOPPTR;
}
$| = 1;
-print "1..13\n";
+print "1..25\n";
open(F,"+>:utf8",'a');
print F chr(0x100).'£';
print "ok 13\n";
close(F);
-# unlink('a');
+{
+$a = chr(300); # This *is* UTF-encoded
+$b = chr(130); # This is not.
+
+open F, ">:utf8", 'a' or die $!;
+print F $a,"\n";
+close F;
+
+open F, "<:utf8", 'a' or die $!;
+$x = <F>;
+chomp($x);
+print "not " unless $x eq chr(300);
+print "ok 14\n";
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+chomp($x);
+print "not " unless $x eq chr(196).chr(172);
+print "ok 15\n";
+close F;
+
+open F, ">:utf8", 'a' or die $!;
+
+print F $a;
+my $y;
+{ my $x = tell(F);
+ { use bytes; $y = length($a);}
+ print "not " unless $x == $y;
+ print "ok 16\n";
+}
+
+{ # Check byte length of $b
+use bytes; my $y = length($b);
+print "not " unless $y == 1;
+print "ok 17\n";
+}
+
+print F $b,"\n"; # This upgrades $b!
+
+{ # Check byte length of $b
+use bytes; my $y = length($b);
+print "not " unless $y == 2;
+print "ok 18\n";
+}
+
+{ my $x = tell(F);
+ { use bytes; $y += 3;}
+ print "not " unless $x == $y;
+ print "ok 19\n";
+}
+
+close F;
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+chomp($x);
+print "not " unless $x eq v196.172.194.130;
+print "ok 20\n";
+
+open F, "<:utf8", "a" or die $!;
+$x = <F>;
+chomp($x);
+close F;
+print "not " unless $x eq chr(300).chr(130);
+print "ok 21\n";
+
+# Now let's make it suffer.
+open F, ">", "a" or die $!;
+eval { print F $a; };
+print "not " unless $@ and $@ =~ /Wide character in print/i;
+print "ok 22\n";
+}
+
+# Hm. Time to get more evil.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+binmode(F, ":bytes");
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq v196.172.130;
+print "ok 23\n";
+
+# Right.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+close F;
+open F, ">>", "a" or die $!;
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq v196.172.130;
+print "ok 24\n";
+
+# Now we have a deformed file.
+open F, "<:utf8", "a" or die $!;
+$x = <F>; chomp $x;
+{ local $SIG{__WARN__} = sub { print "ok 25\n"; };
+eval { sprintf "%vd\n", $x; }
+}
+
+unlink('a');
use strict;
use Config;
-print "1..15\n";
+print "1..17\n";
my $test = 1;
@F = split(/\s+/, $_, 0);
'???'
}
-continue {
- '???'
-}
EOF
print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
}
ok;
+
+# Bug 20001204.07
+{
+my $foo = $deparse->coderef2text(sub { { 234; }});
+# Constants don't get optimised here.
+print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
+ok;
+$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
+print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
+ok;
+}
#!./perl
-print "1..69\n";
+print "1..71\n";
# XXX known to leak scalars
$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
untie $_;
}
+{
+ # BUG 20001205.22
+ my %x;
+ $x{a} = 1;
+ { local $x{b} = 1; }
+ print "not " if exists $x{b};
+ print "ok 70\n";
+ { local @x{c,d,e}; }
+ print "not " if exists $x{c};
+ print "ok 71\n";
+}
Ambiguous use of %c resolved as operator %c
*foo *foo
- Ambiguous -f%c call resolved as a file test [yylex]
- sub f { }; -f(0)
-
__END__
# toke.c
use warnings 'deprecated' ;
"@mjd_previously_unused_array";
EXPECT
Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3.
-########
-# toke.c
-use warnings 'ambiguous';
-sub f { 24 }
--f("TEST");
-print - f("TEST");
-print -(f("TEST"));
-print -f ("TEST");
-print -f "TEST";
-sub Q { 42 };
-print -Q();
-EXPECT
-Ambiguous -f() resolved as a file test at - line 4.
-Ambiguous -f() resolved as a file test at - line 7.
--24-2411-42
-
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw file test %c\n", ftst);
} )
- if (*s == '(' && ckWARN(WARN_AMBIGUOUS))
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
- "Ambiguous -%c() resolved as a file test",
- tmp);
FTST(ftst);
}
else {
/* Assume it was a minus followed by a one-letter named
* subroutine call (or a -bareword), then. */
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### %c looked like a file test but was not\n", ftst);
+ } )
s -= 2;
}
}
projects / p5sagit/p5-mst-13.2.git / commitdiff