view release on metacpan or  search on metacpan

lib/Biblio/bp/lib/bp-p-debug.pl  view on Meta::CPAN

#
# bibliography package for Perl
#
# debugging subroutines
#
# Dana Jacobsen (dana@acm.org)
# 14 January 1995

##################
#
# Debugging code.  We handle assertions, panics with variable dumps,
# debugging statements (with variable levels), consistency checks, and
# variable dumping.
#

# This is assert.pl by Tom Christiansen, but changed slightly.
#
# We should use:
#
#     &panic("function called with no arguments") unless defined $foo;
#
# instead, if that's what you're doing.  First, it's quite a bit faster,
# and second, because panic can be changed to give a usage message.
#

sub assert {
  &panic("Assertion failed: $_[$[]",$@) unless eval $_[$[];
}

sub panic {
  select(STDERR);
  print "\nBP ERROR: @_\n";

  if ($] >= 5.000) {
    local($i,$_);
    local($p,$f,$l,$s,$h,$w,$a,@a,@sub);
    for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
      @a = @DB'args;
      for (@a) {
            if (/^StB\000/ && length($_) == length($_main{'_main'})) {
                $_ = sprintf("%s",$_);
            }
            else {
                s/'/\\'/g;
                s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
                s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
                s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
            }
      }
      $w = $w ? '@ = ' : '$ = ';
      $a = $h ? '(' . join(', ', @a) . ')' : '';
      push(@sub, "$w&$s$a from file $f line $l");
    }
    print join("\n", @sub), "\n";
  }
  &debug_dump('all');
  exit 1;
}


# debugging statement.  Use level for increasing severity.

sub debugs {
  local($statement, $level, $mod) = @_;
  local($debl);

  &panic("debugging called with no arguments")  unless defined $statement;
  &panic("debugging called with no level")      unless defined $level;

  $debl = (defined $mod) ? $glb_moddebug : $glb_debug;

  # False
  return if $debl == 0;
  # True
  return if (  ($debl == 1)  &&  ($opt_default_debug_level > $level)  );
  # some number
  return if $debl > $level;

  local($p,$f,$l,$s,$h,$w);
  if ($] >= 5.000) {
    ($p,$f,$l,$s,$h,$w) = caller(1);
    $s = '' unless defined $s;  # to initialize
    $s =~ s/^bib:://;
  } else {
    # sigh -- caller is broken in perl 4 apparently, so make the best of it
    if (defined $mod) {
      $s = 'mod ' . $glb_current_fmt;
    } else {
      ($p,$f,$l) = caller;
      if ($p ne 'bib') {
        $s = 'pkg ' . $p;
      } else {
        substr($f, 0, rindex($f, '/')+1) = '' if $f =~ /\//;
        if ($f eq 'bp.pl') {
          $s = 'bp';
        } else {
          # if it's one of our packages, strip the header/trailer
          $f =~ s/^${glb_bpprefix}p-(\w+)\.pl/$1/;
          $s = $f;
        }
      }
    }
  }

  local($width) = 16 - &log2($level);

  printf STDERR "BPD: (%14s) %s%s\n", $s, ' ' x $width, $statement;
}

sub log2 {
  log($_[$[]) / log(2);
}


#
# Consistency checker.
#
# This is called in various spots throughout the package, usually before and
# after opening and closing a file, and when changing formats.  This will
# probably go with the production version, but just called fewer times.  It's
# not that long right now, and it doesn't get called often.
#
# The more assertions and double checks here, the better.

sub check_consist {
  local(@incons);
  local(%aainter);

  &debugs("Checking bp variable consistency", 8192);

  # if we're at our maximum debugging level, then spit out copious information
  # each time we're here.
  &debug_dump('all') if $glb_debug == 2;

  local(@ifiles, @ofiles);
  @ifiles = (keys %glb_Irfmt, keys %glb_Ircset, keys %glb_Ifilemap, keys %glb_filelocmap);
  @ofiles = (keys %glb_Orfmt, keys %glb_Orcset, keys %glb_Ofilemap);

  undef %aainter;
  @ifiles = grep($aainter{$_}++ == 0, @ifiles);
  undef %aainter;