#HTML:Support for printf debugging.<BR>

package debug;

require 'site/libmisc.pl';

*DEBUG = *main'DEBUG;#';
*returnn = *misc'returnn;#';
*escstr = *misc'escstr;#';

$" = ', ';

sub do_vardump {
  local($pack) = shift;

  foreach $var (@_) {
    if ($var =~ /^\$/) {
      print DEBUG "$var: ", &valdump($var, $pack), "\n";
    }
    elsif ($var =~ /^[\@\%]/) {
      print DEBUG "$var: (", &valdump($var, $pack, ', '), ")\n";
    }
    else {
      print DEBUG "$var";
    }
  }
}

sub vardump {
  local($pack) = caller;

  unshift(@_, $pack);
  &do_vardump;
}

sub valdump {
  local($var, $pack, $sep) = @_;

  ($pack) = caller unless (defined($pack));
  $sep = $" unless (defined($sep));
  if ($var =~ /^\$/) {
    local($result);

    $result = &eval($var, $pack);
    &escdebugstr($result);
  }
  else {
    join($sep, &escdebugstr(&eval($var, $pack)));
  }
}

sub escdebugstr {
  local($s, @result);

  while (@_) {
    $s = shift(@_);
    if (defined($s)) {
      &escstr($s);
      $s =~ s/[\$\"]/\\$&/g;
      push(@result, "\"$s\"");
    }
    else {
      push(@result, 'undef');
    }
  }
  &returnn(@result);
}

eval <<'EOF' if ($] >= 5);
sub escdebugstr {
  my($s, @result);
  my($tab) = {
    'ARRAY' => sub {push(@result, sprintf("[%s]", join($sep, &escdebugstr(@$s))));},
    'HASH' => sub {
      my(@hash, @s) = &escdebugstr(%$s);

      push(@s, sprintf("%s => %s", splice(@hash, 0, 2))) while (@hash);
      push(@result, sprintf("{%s}", join($sep, @s)));
    },
  };

  while (@_) {
    $s = shift(@_);
    if (defined($s)) {
      my($type) = ref($s);
      my($fun) = $$tab{$type};

      if (defined($fun)) {
	&$fun;
      }
      else {
	&escstr($s);
	$s =~ s/[\$\"]/\\$&/g;
	push(@result, "\"$s\"");
      }
    }
    else {
      push(@result, 'undef');
    }
  }
  &returnn(@result);
}
EOF

sub eval {
  local($expr, $pack) = @_;

  eval("package $pack;$expr");
}

sub printf {
  local($pack) = caller;
  local($frmt) = shift;
  local($!, $var, @temp);

  foreach $var (@_) {
    push(@temp, &valdump($var, $pack, ', '));
  }
  printf DEBUG $frmt, @temp;
}

sub varlog {
  local($pack) = caller;
  local($level) = shift;

  return if $level > $main'debug;#';
  unshift(@_, $pack);
  &do_vardump;
}

1;