view release on metacpan or  search on metacpan

lib/B/Stackobj.pm  view on Meta::CPAN

  return sprintf( "(SvTRUE(%s))", $obj->as_sv );
}

#
# Debugging methods
#
sub peek {
  my $obj   = shift;
  my $type  = $obj->{type};
  my $flags = $obj->{flags};
  my @flags;
  if ( $type == T_UNKNOWN ) {
    $type = "T_UNKNOWN";
  }
  elsif ( $type == T_INT ) {
    $type = "T_INT";
  }
  elsif ( $type == T_NUM ) {
    $type = "T_NUM";
  }
  elsif ( $type == T_STR ) {
    $type = "T_STR";
  }
  else {
    $type = "(illegal type $type)";
  }
  push( @flags, "VALID_INT" )    if $flags & VALID_INT;
  push( @flags, "VALID_NUM" )    if $flags & VALID_NUM;
  push( @flags, "VALID_STR" )    if $flags & VALID_STR;
  push( @flags, "VALID_SV" )     if $flags & VALID_SV;
  push( @flags, "REGISTER" )     if $flags & REGISTER;
  push( @flags, "TEMPORARY" )    if $flags & TEMPORARY;
  @flags = ("none") unless @flags;
  return sprintf( "%s type=$type flags=%s sv=$obj->{sv} iv=$obj->{iv} nv=$obj->{nv}",
    B::class($obj), join( "|", @flags ) );
}

sub minipeek {
  my $obj   = shift;
  my $type  = $obj->{type};
  my $flags = $obj->{flags};
  if ( $type == T_INT || $flags & VALID_INT ) {
    return $obj->{iv};
  }
  elsif ( $type == T_NUM || $flags & VALID_NUM ) {
    return $obj->{nv};
  }
  else {
    return $obj->{sv};
  }
}

#
# Caller needs to ensure that set_int, set_double,
# set_numeric and set_sv are only invoked on legal lvalues.
#
sub set_int {
  my ( $obj, $expr, $unsigned ) = @_;
  my $sval;
  # bullshit detector for non numeric expr, expr 'lnv0 + rnv0'
  if ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
    $sval = $expr;
  } else {
    $sval = B::C::ivx($expr);
    $sval = $expr if $sval eq '0' and $expr;
  }

  runtime("$obj->{iv} = $sval;");
  $obj->{flags} &= ~( VALID_SV | VALID_NUM );
  $obj->{flags} |= VALID_INT | SAVE_INT;
  $obj->{flags} |= VALID_UNSIGNED if $unsigned;
}

sub set_double {
  my ( $obj, $expr ) = @_;
  my $sval;
  if ($expr =~ /^-?(Inf|NaN)$/i) {
    $sval = B::C::nvx($expr);
    $sval = $expr if $sval eq '0' and $expr;
  # bullshit detector for non numeric expr, expr 'lnv0 + rnv0'
  } elsif ($expr =~ /[ a-dfzA-DF-Z]/) { # looks not like number
    $sval = $expr;
  } else {
    $sval = B::C::nvx($expr);
    $sval = $expr if $sval eq '0' and $expr;
  }

  runtime("$obj->{nv} = $sval;");
  $obj->{flags} &= ~( VALID_SV | VALID_INT );
  $obj->{flags} |= VALID_NUM | SAVE_NUM;
}

sub set_numeric {
  my ( $obj, $expr ) = @_;
  if ( $obj->{type} == T_INT ) {
    $obj->set_int($expr);
  }
  else {
    $obj->set_double($expr);
  }
}

sub set_sv {
  my ( $obj, $expr ) = @_;
  runtime("SvSetSV($obj->{sv}, $expr);");
  $obj->invalidate;
  $obj->{flags} |= VALID_SV;
}

#
# Stackobj::Padsv
#

@B::Stackobj::Padsv::ISA = 'B::Stackobj';

sub B::Stackobj::Padsv::new {
  my ( $class, $type, $extra_flags, $ix, $iname, $dname ) = @_;
  $extra_flags |= SAVE_INT    if $extra_flags & VALID_INT;
  $extra_flags |= SAVE_NUM if $extra_flags & VALID_NUM;
  bless {
    type  => $type,
    flags => VALID_SV | $extra_flags,
    targ  => $ix,
    sv    => "PL_curpad[$ix]",
    iv    => "$iname",
    nv    => "$dname",
  }, $class;
}

sub B::Stackobj::Padsv::as_obj {
  my $obj = shift;
  my @c = comppadlist->ARRAY;
  my @p = $c[1]->ARRAY;
  return $p[ $obj->{targ} ];
}

sub B::Stackobj::Padsv::load_int {
  my $obj = shift;
  if ( $obj->{flags} & VALID_NUM ) {
    runtime("$obj->{iv} = $obj->{nv};");
  }