home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / debug.pl < prev    next >
Text File  |  2009-11-06  |  3KB  |  116 lines
  1. # FILE: debug.pl
  2. # DESCRIPTION: Various tools for debugging that we've found useful during development
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### recursive_dump
  20. ###
  21. ### Displays the contents of a hash in a human-readable format
  22. ###
  23.  
  24. sub recursive_dump {
  25.     my ($s, $c, $n) = @_;
  26.     header() if $c == 0;
  27.     if ($c == 0) {
  28.         print "<pre>+ $n (", scalar(keys(%{ $s })), " keys)\n" ;
  29.     } else {
  30.         print "  " x ($c);
  31.         print "+ $n (", scalar(keys(%{ $s })), " keys)\n" ;
  32.     }
  33.     foreach my $k (keys(%{ $s })) {
  34.         if ($k =~ /^_/ && ref $s->{$k} eq "HASH") {
  35.             print "  " x (1 + $c);
  36.             print "+ $k (HASH)\n";
  37.         } elsif (ref $s->{$k} eq "HASH") {
  38.             recursive_dump($s->{$k}, 1+$c, $k);
  39.         } elsif (ref $s->{$k} eq "ARRAY") {
  40.             array_dump($s->{$k}, 1+$c, $k);            
  41.         } else {
  42.             print "  " x (1 + $c);
  43.             print "+ $k: $s->{$k}\n";
  44.         }
  45.     }
  46.     print "</pre>\n" if $c == 0;
  47. }
  48.  
  49. ###
  50. ### array_dump
  51. ###
  52. ### Dumps an array
  53. ###
  54.  
  55. sub array_dump {
  56.     my ($s, $c, $n) = @_;
  57.     header() if $c == 0;
  58.     if ($c == 0) {
  59.         print "<pre>+ \@$n (", scalar(@{$s}), " rows)\n" ;
  60.     } else {
  61.         print "  " x ($c);
  62.         print "+ \@$n (", scalar(@{ $s }), " rows)\n" ;
  63.     }
  64.     foreach my $row (@{ $s }) {
  65.         if (ref $row eq "HASH") {
  66.             recursive_dump($row, 1+$c, $row);
  67.         } elsif (ref $row eq "ARRAY") {
  68.             array_dump($row, 1+$c, $row);            
  69.         } else {
  70.             print "  " x (1 + $c);
  71.             print "+ $row\n";
  72.         }
  73.     }
  74.     print "</pre>\n" if $c == 0;
  75. }
  76.  
  77. ###
  78. ### string_analyze
  79. ###
  80. ### Presents a string in a variety of ways
  81. ###
  82.  
  83. sub string_analyze {
  84.     header();
  85.     dreq("template");
  86.     while (my $s = shift @_) {
  87.         print "<pre>\n";
  88.         print "Absolute string length: ", length($s), "\n";
  89.         print "Source-viewable string: ";
  90.         my $i = $s;
  91.         $i =~ s/\n/\[\\n\]/g;
  92.         $i =~ s/\r/\[\\r\]/g;
  93.         print string_escaper($i);
  94.         print "\n</pre><hr noshade>";
  95.     }
  96. }
  97.  
  98. ###
  99. ### string_escaper
  100. ###
  101. ### For displaying a string on the screen, escaping all characters
  102. ### that are not alphanumeric.
  103. ###
  104.  
  105. sub string_escaper {
  106.     my @u = ();
  107.     while (my $i = shift @_) {    
  108.         $i =~ s/(\W)/join("", "&#", ord($1), ";")/ge;
  109.         push @u, $i;
  110.     }
  111.     return $u[0] if $#u == 0;
  112.     return @u;
  113. }
  114.  
  115. 1;
  116.