B-C
view release on metacpan or search on metacpan
lib/B/Assembler.pm view on Meta::CPAN
}
my $debug = 0;
sub debug { $debug = shift }
my $quiet = 0;
sub quiet { $quiet = shift }
my ( $maxopix, $maxsvix ) = ( 0xffffffff, 0xffffffff );
sub maxopix { $maxopix = shift }
sub maxsvix { $maxsvix = shift }
sub limcheck($$$$) {
my ( $val, $lo, $hi, $loc ) = @_;
if ( $val < $lo || $hi < $val ) {
error "argument for $loc outside [$lo, $hi]: $val";
$val = $hi;
}
return $val;
}
#
# First define all the data conversion subs to which Asmdata will refer
lib/B/Bytecode.pm view on Meta::CPAN
BEGIN {
my $ithreads = defined $Config::Config{'useithreads'} && $Config::Config{'useithreads'} eq 'define';
eval qq{
sub ITHREADS() { $ithreads }
sub VERSION() { $] }
};
die $@ if $@;
}
sub as_hex($) {$quiet ? undef : sprintf("0x%x",shift)}
# Fixes bug #307: use foreach, not each
# each is not safe to use (at all). walksymtable is called recursively which might add
# symbols to the stash, which might cause re-ordered rehashes, which will fool the hash
# iterator, leading to missing symbols.
# Old perl5 bug: The iterator should really be stored in the op, not the hash.
sub walksymtable {
my ($symref, $method, $recurse, $prefix) = @_;
my ($sym, $ref, $fullname);
$prefix = '' unless defined $prefix;
lib/B/Bytecode.pm view on Meta::CPAN
}
} else {
svref_2object(\*$fullname)->$method();
}
}
}
#################################################
# This is for -S commented assembler output
sub op_flags($) {
return '' if $quiet;
# B::Concise::op_flags($_[0]); # too terse
# common flags (see BASOP.op_flags in op.h)
my $x = shift;
my (@v);
push @v, "WANT_VOID" if ( $x & 3 ) == 1;
push @v, "WANT_SCALAR" if ( $x & 3 ) == 2;
push @v, "WANT_LIST" if ( $x & 3 ) == 3;
push @v, "KIDS" if $x & 4;
push @v, "PARENS" if $x & 8;
push @v, "REF" if $x & 16;
push @v, "MOD" if $x & 32;
push @v, "STACKED" if $x & 64;
push @v, "SPECIAL" if $x & 128;
return join( ",", @v );
}
# This is also for -S commented assembler output
sub sv_flags($;$) {
return '' if $quiet or $B::Concise::VERSION < 0.74; # or ($] == 5.010);
return '' unless $debug{Comment};
return 'B::SPECIAL' if $_[0]->isa('B::SPECIAL');
return 'B::PADLIST' if $_[0]->isa('B::PADLIST');
return 'B::PADNAMELIST' if $_[0]->isa('B::PADNAMELIST');
return 'B::NULL' if $_[0]->isa('B::NULL');
my ($sv) = @_;
my %h;
# TODO: Check with which Concise and B versions this works. 5.10.0 fails.
# B::Concise 0.66 fails also
*B::Concise::fmt_line = sub { return shift };
my $op = $ops{ $tix - 1 };
if (ref $op and !$op->targ) { # targ assumes a valid curcv
%h = B::Concise::concise_op( $op );
}
B::Concise::concise_sv( $_[0], \%h, 0 );
}
sub pvstring($) {
my $pv = shift;
defined($pv) ? cstring( $pv . "\0" ) : "\"\"";
}
sub pvix($) {
my $str = pvstring shift;
my $ix = $strtab{$str};
defined($ix) ? $ix : do {
nice1 "-PV- $tix";
B::Assembler::maxsvix($tix) if $debug{A};
asm "newpv", $str;
asm "stpv", $strtab{$str} = $tix;
$tix++;
}
}
# but 5.6.2 works fine
use B
qw(minus_c sv_undef walkoptree walkoptree_slow main_root main_start peekop
cchar svref_2object compile_stats comppadlist hash
threadsv_names main_cv init_av end_av opnumber cstring
HEf_SVKEY SVf_POK SVp_POK SVf_ROK SVf_IOK SVf_NOK SVf_IVisUV SVf_READONLY);
# usually 0x400000, but can be as low as 0x10000
# http://docs.embarcadero.com/products/rad_studio/delphiAndcpp2009/HelpUpdate2/EN/html/devcommon/compdirsimagebaseaddress_xml.html
# called mapped_base on linux (usually 0xa38000)
sub LOWEST_IMAGEBASE() {0x10000}
sub _load_mro {
eval q/require mro; 1/ or die if $] >= 5.010;
*_load_mro = sub {};
}
sub is_using_mro {
return keys %{mro::} > 10 ? 1 : 0;
}
}
}
sub delsym {
my ( $obj ) = @_;
my $sym = sprintf( "s\\_%x", $$obj );
delete $symtable{$sym};
}
sub curcv { $B::C::curcv }
sub set_curcv($) { $B::C::curcv = shift; }
# returns cstring, len, utf8 flags of a string
sub strlen_flags {
my $s = shift;
my ($len, $flags) = (0,"0");
if (!$PERL56 and utf8::is_utf8($s)) {
my $us = $s;
$flags = 'SVf_UTF8';
$len = utf8::upgrade($us);
} else {
lib/B/CC.pm view on Meta::CPAN
if $pad[$ix]->save_double;
declare( "PV",
$type == T_STR
? sprintf( "%s = 0", $pad[$ix]->{sv} )
: $pad[$ix]->{sv} )
if $pad[$ix]->save_str;
}
}
# for cc: unique ascii representation of an utf8 string, for labels
sub encode_utf8($) {
my $l = shift;
if ($] > 5.007 and utf8::is_utf8($l)) {
# utf8::encode($l);
# $l =~ s/([\x{0100}-\x{ffff}])/sprintf("u%x", $1)/ge;
#$l = substr(B::cstring($l), 1, -1);
#$l =~ s/\\/u/g;
$l = join('', map { $_ < 127 ? $_ : sprintf("u_%x_", $_) } unpack("U*", $l));
}
return $l;
}
lib/B/Disassembler.pm view on Meta::CPAN
push @svnames, "PV";
push @svnames, "INVLIST" if $] >= 5.019002; # 4
push @svnames, ("PVIV", "PVNV", "PVMG"); # 4-7
push @svnames, "BM" if $] < 5.009;
push @svnames, "REGEXP" if $] >= 5.011; # 8
push @svnames, "GV" if $] >= 5.009; # 9
push @svnames, ("PVLV", "AV", "HV", "CV"); # 10-13
push @svnames, "GV" if $] < 5.009;
push @svnames, ("FM", "IO"); # 14,15
sub dis_header($) {
my ($fh) = @_;
my $str = $fh->readn(3);
if ($str eq '#! ') {
$str .= $fh->GET_comment_t;
$str .= $fh->GET_comment_t;
$magic = $fh->GET_U32;
} else {
$str .= $fh->readn(1);
$magic = unpack( "L", $str );
}
lib/B/Disassembler.pm view on Meta::CPAN
$byteorder = $fh->GET_strconst();
}
if ( $blversion ge '"0.06_05"' ) {
$archflag = $fh->GET_U16();
}
if ( $blversion ge '"0.06_06"' ) {
$perlversion = $fh->GET_strconst();
}
}
sub get_header() {
my @result = (
$magic, $archname, $blversion, $ivsize,
$ptrsize, $byteorder, $longsize, $archflag,
$perlversion
);
if (wantarray) {
return @result;
}
else {
my $hash = {
script/buildcc.PL view on Meta::CPAN
$l =~ s/^=//;
$Options->{l} = $l;
} else {
# check next ARGV for -
$Options->{l} = '~/.perl5/pcc';
}
@ARGV = grep !/^-l(.*)$/, @ARGV;
}
}
sub opt(*) {
my $opt = shift;
return exists($Options->{$opt}) && ($Options->{$opt} || 0);
}
# File spawning and error collecting
sub spawnit {
my $command = shift;
my (@error,@output,$errname,$errcode);
if (opt('dryrun')) {
print "$command\n";;
script/buildcc.PL view on Meta::CPAN
if ($@) {
eval { kill 'HUP', $pid };
vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
}
close(FD);
return($text);
}
sub is_win32() { $^O =~ m/^MSWin/ }
sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
__END__
=head1 NAME
buildcc - build an executable with shared modules from a perl script
=head1 SYNOPSIS
buildcc -o hello hello.pl # pass thru perlcc
script/perlcc.PL view on Meta::CPAN
eval { require B::C::Config; };
$SIG{INT} = sub { exit(); } if exists $SIG{INT}; # exit gracefully and clean up after ourselves.
use subs qw{
cc_harness check_read check_write checkopts_byte choose_backend
compile_byte compile_cstyle compile_module generate_code
grab_stash parse_argv sanity_check vprint yclept spawnit
vsystem
}; # gettimeofday tv_interval
sub opt(*); # imal quoting
sub is_winlike();
sub is_win32();
sub is_msvc();
our ($Options, $BinPerl, $Backend);
our ($Input => $Output);
our ($logfh);
our ($cfile);
our (@begin_output); # output from BEGIN {}, for testsuite
our ($extra_libs);
# eval { main(); 1 } or die;
script/perlcc.PL view on Meta::CPAN
$Output = 'a.exe';
} else {
$Output .= '.exe';
}
}
$Output = relativize($Output) unless is_win32();
}
sanity_check();
}
sub opt(*) {
my $opt = shift;
return exists($Options->{$opt}) && ($Options->{$opt} || 0);
}
sub module_name {
my $name = $Options->{m};
unless ($name) {
$name = $Input;
$name =~ s/\.p[lm]$//;
if (basename($name) ne $name) {
script/perlcc.PL view on Meta::CPAN
if ($@) {
eval { kill 'HUP', $pid };
vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
}
close(FD);
return($text);
}
sub is_winlike() { $^O =~ m/^(MSWin32|msys|cygwin)/ }
sub is_win32() { $^O =~ m/^(MSWin32|msys)/ }
sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
END {
if ($cfile && !opt('S') && !opt('c') && -e $cfile) {
vprint 4, "Unlinking $cfile";
unlink $cfile;
}
if (opt('staticxs') and !opt('S')) {
vprint 4, "Unlinking $cfile.lst";
unlink "$cfile.lst";
}
# split into platform, version, [feature]
# debian-squeeze-amd64-5.10.1-nt => ("debian-squeeze-amd64", "5.10", "nt")
sub platform_version_split {
local $_ = shift;
my ($p,$v,$f) = m/^(.+)-(5\.[\d\.]+)([-dnt]+)?$/;
$f =~ s/^-// if $f; # d, d-nt, nt or empty
$v =~ s/(\d\.\d+)\.\d+/$1/ if $v;
return ($p,$v,$f);
}
sub h_size($) { scalar keys %{$_[0]} }
sub split_tests($) {
my $t = shift;
map {
if (/(\d+)\.\.(\d+)/) {
($1 .. $2)
} else {
$_
}
} split /,\s*/, $t;
}
t/TestBC.pm view on Meta::CPAN
'\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' .
'\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF';
# The following 2 functions allow tests to work on both EBCDIC and
# ASCII-ish platforms. They convert string scalars between the native
# character set and the set of 256 characters which is usually called
# Latin1.
#
# These routines don't work on UTF-EBCDIC and UTF-8.
sub native_to_latin1($) {
my $string = shift;
return $string if ord('^') == 94; # ASCII, Latin1
my $cp;
if (ord('^') == 95) { # EBCDIC 1047
$cp = \$cp_1047;
}
elsif (ord('^') == 106) { # EBCDIC POSIX-BC
$cp = \$cp_bc;
}
t/TestBC.pm view on Meta::CPAN
$cp = \$cp_0037;
}
else {
die "Unknown native character set";
}
eval '$string =~ tr/' . $$cp . '/' . $straight . '/';
return $string;
}
sub latin1_to_native($) {
my $string = shift;
return $string if ord('^') == 94; # ASCII, Latin1
my $cp;
if (ord('^') == 95) { # EBCDIC 1047
$cp = \$cp_1047;
}
elsif (ord('^') == 106) { # EBCDIC POSIX-BC
$cp = \$cp_bc;
}
t/assembler.t view on Meta::CPAN
is ignored.
=cut
package VirtFile;
use strict;
# Note: This is NOT a general purpose package. It implements
# sequential text and binary file i/o in a rather simple form.
sub TIEHANDLE($;$){
my( $class, $data ) = @_;
my $obj = { data => defined( $data ) ? $data : '',
pos => 0 };
return bless( $obj, $class );
}
sub PRINT($@){
my( $self ) = shift;
$self->{data} .= join( '', @_ );
}
sub WRITE($$;$$){
my( $self, $buf, $len, $offset ) = @_;
unless( defined( $len ) ){
$len = length( $buf );
$offset = 0;
}
unless( defined( $offset ) ){
$offset = 0;
}
$self->{data} .= substr( $buf, $offset, $len );
return $len;
}
sub GETC($){
my( $self ) = @_;
return undef() if $self->{pos} >= length( $self->{data} );
return substr( $self->{data}, $self->{pos}++, 1 );
}
sub READLINE($){
my( $self ) = @_;
return undef() if $self->{pos} >= length( $self->{data} );
# Todo; strip comments and empty lines
my $lfpos = index( $self->{data}, "\n", $self->{pos} );
if( $lfpos < 0 ){
$lfpos = length( $self->{data} );
}
my $pos = $self->{pos};
$self->{pos} = $lfpos + 1;
return substr( $self->{data}, $pos, $self->{pos} - $pos );
}
sub READ($@){
my $self = shift();
my $bufref = \$_[0];
my( undef, $len, $offset ) = @_;
if( $offset ){
die( "offset beyond end of buffer\n" )
if ! defined( $$bufref ) || $offset > length( $$bufref );
} else {
$$bufref = '';
$offset = 0;
}
my $remlen = length( $self->{data} ) - $self->{pos};
$len = $remlen if $remlen < $len;
return 0 unless $len;
substr( $$bufref, $offset, $len ) =
substr( $self->{data}, $self->{pos}, $len );
$self->{pos} += $len;
return $len;
}
sub TELL($){
my $self = shift();
return $self->{pos};
}
sub CLOSE($){
my( $self ) = @_;
$self->{pos} = 0;
}
1;
package main;
use strict;
use Test::More;
t/assembler.t view on Meta::CPAN
use B::Assembler qw( &assemble_fh );
use B::Disassembler qw( &disassemble_fh &get_header );
my( %opsByType, @code2name );
my( $lineno, $dbg, $firstbadline, @descr );
$dbg = 0; # debug switch
# $SIG{__WARN__} handler to catch Assembler error messages
#
my $warnmsg;
sub catchwarn($){
$warnmsg = $_[0];
print "# error: $warnmsg\n" if $dbg;
}
# Callback for writing assembled bytes. This is where we check
# that we do get an error.
#
sub putobj($){
if( ++$lineno >= $firstbadline ){
ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
undef( $warnmsg );
} else {
my $l = syswrite( OBJ, $_[0] );
}
}
# Callback for writing a disassembled statement.
# Fixed to support the new optional verbose argument, which we ignore here.
sub putdis(@){
my ($insn, $arg, $verbose) = @_;
my $line = defined($arg) ? "$insn $arg" : $insn;
++$lineno;
print DIS "$line\n";
if ($dbg) {
$verbose = 0 unless $verbose;
printf ("# %5d %s verbose:%d\n", $lineno, $line, $verbose);
}
}
# Generate assembler instructions from a hash of operand types: each
# existing entry contains a list of good or bad operand values. The
# corresponding opcodes can be found in %opsByType.
#
sub gen_type($$$){
my( $href, $descref, $text ) = @_;
for my $odt ( sort( keys( %opsByType ) ) ){
my $opcode = $opsByType{$odt}->[0];
my $sel = $odt;
$sel =~ s/^GET_//;
die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
if( defined( $href->{$sel} ) ){
if( @{$href->{$sel}} ){
for my $od ( @{$href->{$sel}} ){
++$lineno;
t/issue235.t view on Meta::CPAN
use Test::More tests => 2;
use B::C;
my $when = "1.42_61";
ctest(1,'6','C,-O3,-UCarp','ccode235i',<<'EOF',($B::C::VERSION lt $when ? "TODO #235 assert !CvCVGV_RC(cv)" : "#235 bytes::length"));
BEGIN{$INC{Carp.pm}++}
my ($d,$ol); $d = pack("U*", 0xe3, 0x81, 0xAF); { use bytes; $ol = bytes::length($d) } print $ol
EOF
ctest(2,'^Not enough arguments for main','C,-O3','ccode235i',<<'EOF',"#246 missing proto decl for empty subs");
sub foo($\@); eval q/foo "s"/; print $@
EOF
t/issue390.t view on Meta::CPAN
@plan = (tests => 1);
}
}
use Test::More @plan;
#use B::C ();
#my $todo = ($B::C::VERSION le '1.56') ? "TODO" : "";
my $todo = "TODO";
ctestok(1,'C,-O3','ccode390i',<<'EOF',$todo.' \#390 backref REFCOUNTED flag');
print test(); print test();
sub test() {
*test = sub () { "k" };
"o";
}
EOF
t/issue81.t view on Meta::CPAN
plan skip_all => "illegal prototypes with cperl" if $^V =~ /c$/;
plan tests => 3;
use strict;
BEGIN {
unshift @INC, 't';
require TestBC;
}
my $name='ccode81i';
my $script = <<'EOF';
sub int::check {1} #create int package for types
sub x(int,int) { @_ } #cvproto
print "o" if prototype \&x eq "int,int";
sub y($) { @_ } #cvproto
print "k" if prototype \&y eq "\$";
EOF
use B::C;
my $todo = ($B::C::VERSION lt '1.37' ? "TODO " : "");
my $todocc = ($B::C::VERSION lt '1.42_61' ? "TODO " : "");
plctestok(1, $name, $script, "${todo}BC cvproto");
ctestok(2, "C", $name, $script, "${todo}C cvproto");
$todocc = "TODO 5.24 " if $] > 5.023007;
t/perldoc.t view on Meta::CPAN
plan skip_all => "mingw" if ($^O eq 'MSWin32' and $Config{cc} eq 'gcc'); # fail 1,4
plan skip_all => "-flto too slow" if $ENV{PERL_CORE} and $has_flto;
plan tests => 7;
$perlcc .= " --Wc=-O1" if $has_flto;
my $exe = $Config{exe_ext};
my $perldocexe = $^O eq 'MSWin32' ? "perldoc$exe" : "./perldoc$exe";
my $strip_banner = 0;
# check if we need to strip 1st and last line. Needed for 5.18-5.20
sub strip_banner($) {
my $s = shift;
$s =~ s/^.* User Contributed Perl Documentation (.*?)$//m;
$s =~ s/^perl v.*$//m;
return $s;
}
my ($compile, $res, $result, $ori, $out, $err, $t0, $t1, $t2);
# XXX interestingly 5.8 perlcc cannot compile perldoc because Cwd disturbs the method finding
# vice versa 5.14 cannot compile perldoc manually because File::Temp is not included
# ok with "utf-8-strict"
tests[75]='use Encode;
my $x = "abc";
print "ok" if "abc" eq Encode::decode("UTF-8", $x);'
tests[76]='use warnings;
{ no warnings q(void); # issue76 lexwarn
length "ok";
print "ok"
};'
tests[81]='%int::; #create int package for types
sub x(int,int) { @_ } #cvproto
my $o = prototype \&x;
if ($o eq "int,int") {print "o"}else{print $o};
sub y($) { @_ } #cvproto
my $p = prototype \&y;
if ($p eq q($)) {print "k"}else{print $p};
require bytes;
sub my::length ($) { # possible prototype mismatch vs _
if ( bytes->can(q(length)) ) {
*length = *bytes::length;
goto &bytes::length;
}
return CORE::length( $_[0] );
}
$abc = join(":", sort(keys %abc::));
package abc;
print "variable: $blurfl\n";
print "eval: ". eval q/"$blurfl\n"/;
package main;
sub ok { 1 }'
result[212]='variable: 5
eval: 5'
tests[214]='
my $expected = "foo";
sub check(_) { print( (shift eq $expected) ? "ok\n" : "not ok\n" ) }
$_ = $expected;
check;
undef $expected;
✓ # $_ not passed'
result[214]='ok
ok'
tests[215]='eval { $@ = "t1\n"; do { die "t3\n" }; 1; }; print ":$@:\n";'
result[215]=':t3
:'
tests[216]='eval { $::{q{@}}=42; }; print qq{ok\n}'
*STDOUT; sub IO::Handle::self { $_[0] };
(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"'
tests[3301]='#WORKAROUND 3300
IO::Handle->new if $ENV{none}; *STDOUT; sub IO::Handle::self { $_[0] };
(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"'
tests[367]='#BROKEN since 5.22 (METHOP for binc)
use Math::BigInt;
my $x = Math::BigInt->new('1' x 20);
print "ok" if ++$x eq "11111111111111111112";'
tests[390]='print test(); print test();
sub test() {
*test = sub () { "k" };
"o";
}'
tests[391]='use warnings "closed"; eval "warn qq(\n); print qq(ok\n)";'
tests[400]='#TODO
use Class::XSAccessor constructor => "new", accessors => [ "foo" ];
my $o = main::->new( foo => "ok" );
print $o->foo,"\n";'
tests[4001]='require Class::XSAccessor;
Class::XSAccessor->import(constructor => "new", accessors => [ "foo" ]);
t/testcc.sh view on Meta::CPAN
# ok with "utf-8-strict"
tests[75]='use Encode;
my $x = "abc";
print "ok" if "abc" eq Encode::decode("UTF-8", $x);'
tests[76]='use warnings;
{ no warnings q(void); # issue76 lexwarn
length "ok";
print "ok"
};'
tests[81]='%int::; #create int package for types
sub x(int,int) { @_ } #cvproto
my $o = prototype \&x;
if ($o eq "int,int") {print "o"}else{print $o};
sub y($) { @_ } #cvproto
my $p = prototype \&y;
if ($p eq q($)) {print "k"}else{print $p};
require bytes;
sub my::length ($) { # possible prototype mismatch vs _
if ( bytes->can(q(length)) ) {
*length = *bytes::length;
goto &bytes::length;
}
return CORE::length( $_[0] );
}
t/testcc.sh view on Meta::CPAN
$abc = join(":", sort(keys %abc::));
package abc;
print "variable: $blurfl\n";
print "eval: ". eval q/"$blurfl\n"/;
package main;
sub ok { 1 }'
result[212]='variable: 5
eval: 5'
tests[214]='
my $expected = "foo";
sub check(_) { print( (shift eq $expected) ? "ok\n" : "not ok\n" ) }
$_ = $expected;
check;
undef $expected;
✓ # $_ not passed'
result[214]='ok
ok'
tests[215]='eval { $@ = "t1\n"; do { die "t3\n" }; 1; }; print ":$@:\n";'
result[215]=':t3
:'
tests[216]='eval { $::{q{@}}=42; }; print qq{ok\n}'
t/testcc.sh view on Meta::CPAN
*STDOUT; sub IO::Handle::self { $_[0] };
(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"'
tests[3301]='#WORKAROUND 3300
IO::Handle->new if $ENV{none}; *STDOUT; sub IO::Handle::self { $_[0] };
(*STDOUT->self . "") =~ m/^GLOB/ and print "ok\n"'
tests[367]='#BROKEN since 5.22 (METHOP for binc)
use Math::BigInt;
my $x = Math::BigInt->new('1' x 20);
print "ok" if ++$x eq "11111111111111111112";'
tests[390]='print test(); print test();
sub test() {
*test = sub () { "k" };
"o";
}'
tests[391]='use warnings "closed"; eval "warn qq(\n); print qq(ok\n)";'
tests[400]='#TODO
use Class::XSAccessor constructor => "new", accessors => [ "foo" ];
my $o = main::->new( foo => "ok" );
print $o->foo,"\n";'
tests[4001]='require Class::XSAccessor;
Class::XSAccessor->import(constructor => "new", accessors => [ "foo" ]);
t/testplc.sh view on Meta::CPAN
tests[51]='$SIG{__WARN__}=sub{print "ok"};warn 1;'
# check if general signals work
tests[511]='BEGIN{$SIG{USR1}=sub{$w++;};} kill USR1 => $$; print q(ok) if $w'
tests[68]='package A;sub test{use Data::Dumper();$_ =~ /^(.*?)\d+$/;"Some::Package"->new();}print q(ok);'
#-------------
# issue27
tests[70]='require LWP::UserAgent;print q(ok);'
# issue24
tests[71]='dbmopen(%H,q(f),0644);print q(ok);'
tests[81]='%int::; #create int package for types
sub x(int,int) { @_ } #cvproto
my $o = prototype \&x;
if ($o eq "int,int") {print "o"}else{print $o};
sub y($) { @_ } #cvproto
my $p = prototype \&y;
if ($p eq q($)) {print "k"}else{print $p};
require bytes;
sub my::length ($) { # possible prototype mismatch vs _
if ( bytes->can(q(length)) ) {
*length = *bytes::length;
goto &bytes::length;
}
return CORE::length( $_[0] );
}
t/testplc.sh view on Meta::CPAN
$abc = join(":", sort(keys %abc::));
package abc;
print "variable: $blurfl\n";
print "eval: ". eval q/"$blurfl\n"/;
package main;
sub ok { 1 }'
result[212]='variable: 5
eval: 5'
tests[214]='
my $expected = "foo";
sub check(_) { print( (shift eq $expected) ? "ok\n" : "not ok\n" ) }
$_ = $expected;
check;
undef $expected;
✓ # $_ not passed'
result[214]='ok
ok'
tests[215]='eval { $@ = "t1\n"; do { die "t3\n" }; 1; }; print ":$@:\n";'
result[215]=':t3
:'
tests[216]='eval { $::{q{@}}=42; }; print qq{ok\n}'
( run in 0.960 second using v1.01-cache-2.11-cpan-65fba6d93b7 )