# w3dumpvar.pl v0.1 by Brooks Cutter (bcutter@stuff.com)
# modified from standard dumpvar by Randal Schwartz. (99% of the code is his..)
#
# This is a modified version of the dumpvar that comes with the standard
# perl v4.036 distribution.  This modified dumpvar is useful for use
# with CGI scripts and other programs that generate HTML output.
# This package hides it's output with <!-- SGML comment tags -->
# and escapes '<' and '>' in the output so it won't be interpreted by
# web browsers (like Mosaic)
#
# What this package does that dumpvar doesn't:
#
# 1. puts a nice header that lists the arguments to dumpvar, like:
# <!-- dumpvar(main,var1,var1)
# 2. Translates all '<' and '>' to &lt; and &gt; respectively
# 3. For assoc array's that simulate multi-dimensional arrays by concatenating
#    keys with the '$;' character, this dumpvar splits them out..
#   For example, given:
#    $assoc_array{'key1','key2','key3'} = 1;
#   the standard dumpvar would print this as:
#    %assoc_array = (
#      key1key2key3  '1'
#    )
#   w3dumpvar.pl will print this as:
#    <!-- dumpvar(main,assoc_array)  caller(main,foo,3)
#    %assoc_array = (
#    ('key1','key2','key3')  '1'
#    )
#    -->

package dumpvar;

# translate control chars to ^X - Randal Schwartz
sub unctrl {
  local($_) = @_;
  s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  s/>/&gt;/g; # convert > to &gt;
  s/</&lt;/g; # convert < to &lt;
  $_;
}
sub main'dumpvar {
  ($package,@vars) = @_;
  print "\n<!-- dumpvar(",join(',',@_),")  caller(",join(',',caller),")\n";
  local(*stab) = eval("*_$package");
  while (($key,$val) = each(%stab)) {
    next if @vars && !grep($key eq $_,@vars);
    local(*entry) = $val;
    if (defined $entry) {
      print "\$$key = '",&unctrl($entry),"'\n";
    }
    if (defined @entry) {
      print "\@$key = (\n";
      foreach $num ($[ .. $#entry) {
        print "  $num\t'",&unctrl($entry[$num]),"'\n";
      }
      print ")\n";
    }
    if ($key ne "_$package" && $key ne "_DB" && defined %entry) {
      print "\%$key = (\n";
      foreach $key (sort keys(%entry)) {
        if (index($key,$;) == -1) {
            print "('$key')\t'",&unctrl($entry{$key}),"'\n";
        } else {
          @keys = split(/$;/,$key),
          print "('",join("','",@keys),"')\t'", &unctrl($entry{$key}),"'\n";
        }
      }
      print ")\n";
    }
  }
  print "\n-->\n";
}

1;