Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

merge master into inc_cleanup

  • Loading branch information...
commit 2888b393a362983996af862fa658ca3511c8f8bc 2 parents 740401d + 60a4612
@rurban authored
View
5 Changes
@@ -24,7 +24,10 @@
Fixed 5.15.2 hang at hfree_next_entry (issue 78)
Defer writing of READONLY hash keys since 5.15 (issue 88)
Enable -fcog copy-on-grow with static strings for >= 5.10
- * CC (1.12) allow overriding of -f<opt> B::C flags
+ Improved Errno vs. *main::! and Tie::Hash::NamedCapture vs *main::+ / - logic (issue 90)
+ * CC (1.12): allow overriding of -f<opt> B::C flags
+ * Bytecode (1.12): detect Tie::Hash::NamedCapture (issue 90)
+ support -d debugging without -MOd
* perlcc (2.13): added options -O1-4, -u, -U, --Wc, --Wl, --version,
Keep cfile if output is empty.
Changed verbosity levels and output wording.
View
1  MANIFEST
@@ -124,6 +124,7 @@ t/issue54.t
t/issue71.t
t/issue76.t
t/issue81.t
+t/issue90.t
t/modules.pm
t/modules.t
t/mymodules
View
11 lib/B/Bytecode.pm
@@ -3,6 +3,7 @@
# Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved.
# Copyright (c) 2003 Enache Adrian. All rights reserved.
# Copyright (c) 2008-2011 Reini Urban <rurban@cpan.org>. All rights reserved.
+# Copyright (c) 2011 cPanel Inc. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
@@ -12,7 +13,7 @@
package B::Bytecode;
-our $VERSION = '1.11';
+our $VERSION = '1.12';
#use 5.008;
use B qw(class main_cv main_root main_start
@@ -497,8 +498,9 @@ sub B::PVMG::domagic {
nice1 '-' . class($sv) . '-', asm "ldsv", $varix = $ix unless $ix == $varix;
for (@mglist) {
+ next unless ord($_->TYPE);
asm "sv_magic", ord($_->TYPE), cstring $_->TYPE;
- asm "mg_obj", shift @mgix;
+ asm "mg_obj", shift @mgix; # D sets itself, see mg.c:mg_copy
my $length = $_->LENGTH;
if ( $length == B::HEf_SVKEY and !$PERL56) {
asm "mg_namex", shift @namix;
@@ -645,7 +647,7 @@ sub B::GV::desired {
my $gv = shift;
my ( $cv, $form );
if ( $debug{Gall} and !$PERL510 ) {
- select *STDERR;
+ select *STDERR;
eval "require B::Debug;";
$gv->debug;
select *STDOUT;
@@ -1105,6 +1107,7 @@ sub compile {
my ( $head, $scan, $keep_syn, $module );
my $cwd = '';
$files{$0} = 1;
+ $DB::single=1 if defined &DB::DB;
# includeall mode (without require):
if ($includeall) {
# add imported symbols => values %INC
@@ -1435,7 +1438,7 @@ modified by Benjamin Stuhl <sho_pi@hotmail.com>.
Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
-Enhanced by Reini Urban <rurban@cpan.org>, 2008-
+Enhanced by Reini Urban <rurban@cpan.org>, 2008-2011
=cut
View
46 lib/B/C.pm
@@ -2834,6 +2834,10 @@ if (0) {
my $gvname = $gv->NAME;
my $package = $gv->STASH->NAME;
return $sym if $skip_package{$package};
+
+ #XXX Tie::Hash::NamedCapture is added for *main::+ or *main::-
+ #XXX Errno is added for *main::!
+
my $is_empty = $gv->is_empty;
my $fullname = $package . "::" . $gvname;
my $name = cstring($fullname);
@@ -2939,7 +2943,7 @@ if (0) {
if ( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
$savefields = Save_HV | Save_AV | Save_SV | Save_CV | Save_FORM | Save_IO;
}
- elsif ( $gvname eq '!' ) { #Errno
+ elsif ( $fullname eq 'main::!' ) { #Errno
$savefields = Save_HV;
}
# issue 79: Only save stashes for stashes.
@@ -2971,6 +2975,10 @@ if (0) {
warn "Skipping GV::save \@$fullname\n" if $debug{gv};
} else {
warn "GV::save \@$fullname\n" if $debug{gv};
+ if ($fullname eq 'main::+' or $fullname eq 'main::-') {
+ $init->add("/* \@$gvname force saving of Tie::Hash::NamedCapture */");
+ mark_package('Tie::Hash::NamedCapture', 1);
+ }
$gvav->save($fullname);
$init->add( sprintf( "GvAV($sym) = s\\_%x;", $$gvav ) );
}
@@ -2982,6 +2990,13 @@ if (0) {
}
if ($fullname ne 'main::ENV') {
warn "GV::save \%$fullname\n" if $debug{gv};
+ if ($fullname eq 'main::!') { # force loading Errno
+ $init->add("/* \%! force saving of Errno */");
+ mark_package('Errno', 1); # B::C needs Errno but does not import $!
+ } elsif ($fullname eq 'main::+' or $fullname eq 'main::-') {
+ $init->add("/* \%$gvname force saving of Tie::Hash::NamedCapture */");
+ mark_package('Tie::Hash::NamedCapture', 1);
+ }
# XXX TODO 49: crash at BEGIN { %warnings::Bits = ... }
$gvhv->save($fullname);
$init->add( sprintf( "GvHV($sym) = s\\_%x;", $$gvhv ) );
@@ -4519,6 +4534,7 @@ sub in_static_core {
# version has an external ::vxs
sub static_core_packages {
my @pkg = qw(Internals utf8 UNIVERSAL);
+ # Tie::Hash::NamedCapture is dynamic
push @pkg, qw(version) if $] >= 5.010; # partially static and dynamic
push @pkg, qw(DynaLoader) if $Config{usedl};
# Win32CORE only in official cygwin pkg. And it needs to be bootstrapped,
@@ -4789,6 +4805,34 @@ sub inc_cleanup {
sub save_context {
# forbid run-time extends of curpad syms, names and INC
warn "save context:\n" if $verbose;
+
+ if ($PERL510) {
+ # Tie::Hash::NamedCapture is added for *main::+ or *main::-
+ # Errno is added for *main::!
+ no strict 'refs';
+ if ( defined(objsym(svref_2object(\*{'main::+'}))) or defined(objsym(svref_2object(\*{'main::-'}))) ) {
+ use strict 'refs';
+ if (!$include_package{'Tie::Hash::NamedCapture'}) {
+ $init->add("/* force saving of Tie::Hash::NamedCapture */");
+ mark_package('Tie::Hash::NamedCapture', 1);
+ } # else already included
+ } else {
+ use strict 'refs';
+ delete_unsaved_hashINC('Tie::Hash::NamedCapture');
+ }
+ no strict 'refs';
+ if ( defined(objsym(svref_2object(\*{'main::!'}))) ) {
+ use strict 'refs';
+ if (!$include_package{'Errno'}) {
+ $init->add("/* force saving of Errno */");
+ mark_package('Errno', 1);
+ } # else already included
+ } else {
+ use strict 'refs';
+ delete_unsaved_hashINC('Errno');
+ }
+ }
+
$init->add("/* curpad names */");
warn "curpad names:\n" if $verbose;
# Record comppad sv's names, may not be static
View
56 t/issue90.t
@@ -0,0 +1,56 @@
+#! /usr/bin/env perl
+# http://code.google.com/p/perl-compiler/issues/detail?id=90
+# Magic Tie::Named::Capture <=> *main::+ main::*- and Errno vs !
+use Test::More tests => 9;
+use strict;
+BEGIN {
+ die "1..0 #requires 5.10\n" if $] < 5.010;
+ unshift @INC, 't';
+ require "test.pl";
+}
+
+sub save {
+ my $name = shift;
+ my $script = join("\n",@_);
+ open my $s, ">$name.pl";
+ print $s $script;
+ close $s;
+}
+
+sub test3 {
+ my $name = shift;
+ my $script = shift;
+ save($name, $script);
+ my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
+ system($runperl,'-Mblib',"-MO=Bytecode,-o$name.plc","$name.pl");
+ my $runexe = qx($runperl -Mblib -MByteLoader $name.plc);
+ TODO: {
+ local $TODO = '%+ setting regdata magic crashes' if $name eq 'ccode90i_c';
+ is($runexe, 'ok', "Bytecode $name");
+ }
+ ctestok(2, "C", $name, $script, @_);
+ ctestok(3, "CC", $name, $script, @_);
+ #unlink("$name.plc", "$name.pl");
+ #unlink("$name_2.c", "$name_2");
+ #unlink("$name_3.c", "$name_3");
+}
+
+
+test3('ccode90i_c', <<'EOF');
+my $s = 'test string';
+$s =~ s/(?<first>test) (?<second>string)/\2 \1/g;
+print q(o) if $s eq 'string test';
+'test string' =~ /(?<first>\w+) (?<second>\w+)/;
+print q(k) if $+{first} eq 'test';
+EOF
+
+test3('ccode90i_es', <<'EOF');
+my %errs = %!; # t/op/magic.t Errno compiled in
+print q(ok) if defined ${"!"}{ENOENT};
+EOF
+
+# this fails so far, %{"!"} is not detected at compile-time. requires -uErrno
+test3('ccode90i_er', <<'EOF', 'requires -uErrno');
+my %errs = %{"!"}; # t/op/magic.t Errno to be loaded at run-time
+print q(ok) if defined ${"!"}{ENOENT};
+EOF
View
6 t/testc.sh
@@ -373,6 +373,12 @@ sub my::length ($) { # possible prototype mismatch vs _
}
print my::length($p);'
result[81]='ok1'
+tests[90]='my $s = q(test string);
+$s =~ s/(?<first>test) (?<second>string)/\2 \1/g;
+print q(o) if $s eq q(string test);
+q(test string) =~ /(?<first>\w+) (?<second>\w+)/;
+print q(k) if $+{first} eq q(test);'
+result[90]='ok'
# from here on we test CC specifics only
View
6 t/testplc.sh
@@ -332,6 +332,12 @@ print "o" if prototype \&x eq "int,int";
sub y($) { @_ } #cvproto
print "k" if prototype \&y eq "\$";'
result[81]='12'
+tests[90]='my $s = q(test string);
+$s =~ s/(?<first>test) (?<second>string)/\2 \1/g;
+print q(o) if $s eq q(string test);
+q(test string) =~ /(?<first>\w+) (?<second>\w+)/;
+print q(k) if $+{first} eq q(test);'
+result[90]='ok'
init
Please sign in to comment.
Something went wrong with that request. Please try again.