Acme-Perl-VM
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/Acme/Perl/VM.pm view on Meta::CPAN
# Utilities
sub sv_defined{
my($sv) = @_;
return $sv && ${$sv} && defined(${ $sv->object_2svref });
}
sub is_not_null{
my($sv) = @_;
return ${$sv};
}
sub is_null{
my($sv) = @_;
return !${$sv};
}
my %not_a_scalar;
@not_a_scalar{qw(AV HV CV IO)} = ();
sub is_scalar{
my($sv) = @_;
return !exists $not_a_scalar{ $sv->class };
}
sub mark_list{
my($mark) = @_;
return map{ ${ $_->object_2svref } } splice @PL_stack, $mark+1;
}
our %external;
sub apvm_extern{
foreach my $arg(@_){
if(ref $arg){
if(ref($arg) ne 'CODE'){
Carp::croak('Not a CODE reference for apvm_extern()');
}
$external{refaddr $arg} = 1;
}
else{
my $stash = do{ no strict 'refs'; \%{$arg .'::'} };
while(my $name = each %{$stash}){
my $code_ref = do{ no strict 'refs'; *{$arg . '::' . $name}{CODE} };
if(defined $code_ref){
$external{refaddr $code_ref} = 1;
}
}
}
}
return;
}
sub cv_external{
my($cv) = @_;
return $cv->XSUB || $external{ ${$cv} };
}
sub ddx{
require Data::Dumper;
my $ddx = Data::Dumper->new(@_);
$ddx->Indent(1);
$ddx->Terse(TRUE);
$ddx->Quotekeys(FALSE);
$ddx->Useqq(TRUE);
return $ddx if defined wantarray;
my $name = ( split '::', (caller 2)[3] )[-1];
print STDERR $name, ': ', $ddx->Dump(), "\n";
return;
}
sub dump_object{
ddx([[ map{ $_ ? $_->object_2svref : $_ } @_ ]]);
}
sub dump_value{
ddx([\@_]);
}
sub dump_stack{
require Data::Dumper;
no warnings 'once';
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Terse = TRUE;
local $Data::Dumper::Quotekeys = FALSE;
local $Data::Dumper::Useqq = TRUE;
deb "(%s)\n", join q{,}, map{
# find variable name
my $varname = '';
my $class = $_->class;
if($class eq 'SPECIAL'){
($varname = $_->special_name) =~ s/^\&PL_//;
$varname;
}
elsif($class eq 'CV'){
$varname = '&' . gv_fullname($_->GV);
}
else{
for(my $padix = 0; $padix < @PL_curpad; $padix++){
my $padname;
if(${ $PL_curpad[$padix] } == ${ $_ }){
$padname = $PL_comppad_name->ARRAYelt($padix);
}
elsif($_->ROK && ${$PL_curpad[$padix]} == ${ $_->RV }){
$padname = $PL_comppad_name->ARRAYelt($padix);
$varname .= '\\';
}
if($padname){
if($padname->POK){
$varname .= $padname->PVX . ' ';
}
last;
}
}
$varname . Data::Dumper->Dump([is_scalar($_) ? ${$_->object_2svref} : $_->object_2svref], [$_->ROK ? 'SV' : '*SV']);
}
} @PL_stack;
return;
}
sub _dump_stack{
my $warn;
my $ddx = ddx([[map{
if(ref $_){
is_scalar($_) ? ${$_->object_2svref} : $_->object_2svref;
}
else{
$warn++;
$_;
}
} @PL_stack]], ['*PL_stack']);
$ddx->Indent(0);
deb " %s\n", $ddx->Dump();
if($warn){
apvm_die 'No sv found (%d)', $warn;
}
return;
}
sub dump_si{
my %stack_info = (
stack => \@PL_stack,
markstack => \@PL_markstack,
cxstack => \@PL_cxstack,
scopstack => \@PL_scopestack,
savestack => \@PL_savestack,
tmps => \@PL_tmps,
);
ddx([\%stack_info]);
}
sub not_implemented{
if(!@_){
if($PL_op && is_not_null($PL_op)){
@_ = ($PL_op->name);
}
else{
@_ = (caller 0)[3];
}
}
push @_, ' is not implemented';
goto &Carp::confess;
}
sub call_sv{ # perl.h
my($sv, $flags) = @_;
if($flags & G_DISCARD){
ENTER;
SAVETMPS;
view all matches for this distributionview release on metacpan - search on metacpan
( run in 1.265 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )