view release on metacpan or  search on metacpan

Harness/Handler.pm  view on Meta::CPAN

    my $fh = $harness->{_outFH};
    return unless $fh;

    print $fh '<'.(defined($rpt->[0])?$rpt->[0]:'T');
    print $fh " _i='$trace->[HNDLR_ID]' _m='$mode'" if $mode;
    my $closeTag = '/>';

    my $hsh = $rpt->[1];
    map { print $fh " $_='".xml_quote($hsh->{$_})."'" if defined $hsh->{$_} } keys %$hsh;

    if ( defined $rpt->[2] ) {
        print $fh '>'; $closeTag = '</'.(defined($rpt->[0])?$rpt->[0]:'T').'>';
        for ( @{$rpt->[2]} ) {
            $self->harnessPrintReport(undef, undef, $_);
        }
    }

    if ( defined $rpt->[3] ) {
        print $fh '>'; $closeTag = '</'.(defined($rpt->[0])?$rpt->[0]:'T').'>';
        print $fh $rpt->[3];
    }

    print $fh $closeTag;
    $self->[HNDLR_REPORT] = undef;
}

### ###########################################################################
# USAGE: Invoked by attach()'d subroutine: see above.
# This is, presumably, overridden by the sub-harness.
sub OnSubEntry {
    my $self = shift;
    return @_;
}

### ###########################################################################
# USAGE: Invoked by attach()'d subroutine: see above.
# This is, presumably, overridden by the sub-harness.
sub OnSubExit {
    my $self = shift;
    return @_;
}


### ###########################################################################
# USAGE: Harness::Variables(list of any variable(s));
sub Variables {
  my $self = ref($_[0])?shift:$Benchmark::Harness::Harness;
  return unless ref($self);
  return unless $self->{_outFH};
}


### ###########################################################################
# USAGE: Harness::Arguments(@_);
sub ArgumentsXXX {
  my $self = shift;
  return $self unless ref($self);
  return $self unless $self->{_outFH};

  $self->_PrintT('-Arguments', caller(1));

  my $i = 1;
  for ( @_ ) {
    my $obj = ref($_)?$_:\$_;
    my ($nm, $sz) = (ref($_), Devel::Size::total_size($_));
    $nm = $i unless $nm; $i += 1;
    $self->print("<V n='$nm' s='$sz'/>");
  }
  $self->_PrintT_();
  return $self;
}

### ###########################################################################
# USAGE: Harness::NamedObject($name, $self); - where $self is a blessed reference.
sub NamedObjects {
  my $self = shift;
  return $self unless ref($self);

    my %objects = @_;
    for ( keys %objects ) {
        $self->reportValueInfo(
                    {   'n' => $_,
                        'v' => $objects{$_},
                    }
                );
    }
    return $self;
}

### ###########################################################################
# USAGE: Harness::Object($obj); - where $obj is an object reference.
sub Object {
  my $self = shift;
  return $self unless ref($self);
  my $pckg = $_[0];

  my $pckgName = "$pckg";
  $pckgName =~ s{=?(ARRAY|HASH|SCALAR).*$}{};
  my $pckgType = $1;
  $self->_PrintT("-$pckgType $pckgName", caller(1));
  $self->OnObject(@_);

  $self->_PrintT_();
  return $self;
}

### ###########################################################################
# USAGE: Benchmark::MemoryUsage::MethodReturn( $pckg )
#     Print useful information about the given object ($pckg)
sub OnObject {
  my $self = shift;
  my $obj = shift;

  my $objName = "$obj";
  $objName =~ s{=?([A-Z]+).*$}{};#s{=?(ARRAY|HASH|SCALAR|CODE).*$}{};
  my $objType = $1 || '';

  if ( $objType eq 'HASH' ) {
    my $i = 0;
    for ( keys %$obj ) {
      my $obj = ref($_)?$_:\$_;
      my ($nm) = ($_);
      $nm = $i unless $nm; $i += 1;
      $self->print("<V n='$nm'/>");
    }
  } elsif ( $objType eq 'ARRAY' ) {
        my $i = 0;
        for ( @$obj ) {
        my ($nm) = ($i);
        $i += 1;
        $self->print("<V n='$nm'/>");
        last if ( ++$i == 20 );
        if ( scalar(@$objType) > 20 ) {
            $self->print("<G n='".scalar(@_)."'/>");
        };
    }
  } elsif ( $objType eq 'SCALAR' ) {
      $self->print("<V>$$obj</V>");
  } else {
      $self->print("<V t='$objType'>$obj</V>");
  }
  return $self;
}

### ###########################################################################
# USAGE: Harness::NamedVariables('name1' => $variable1 [, 'name1' => $variable2 ])
sub NamedVariables {
  my $self = ref($_[0])?shift:$Benchmark::Harness::Harness;
  return $self unless ref($self);

  $self->_PrintT(undef, caller(1));

  my $i = 1;
  while ( @_ ) {
    my ($nm, $sz) = (shift, Devel::Size::total_size(shift));
    $nm = $i unless $nm; $i += 1;
    $self->print("<V n='$nm' s='$sz'/>");
  }
  $self->_PrintT_();
  return $self;
}

1;