—
—
—
—
—
—
—

              
package VCP::Debug ;
HideShow 23 lines of Pod
=head1 NAME
VCP::Debug - debugging support for VCP
=head1 SYNOPSIS
=head1 DESCRIPTION
=head1 EXPORTS
The following functions may be exported: L</debug>, L</enable_debug>,
L</debugging>
L</disable_debug>, along with the tags ':all' and ':debug'.  Use the latter
to head off future namespace pollution in case :all gets expanded in the
future..
A warning will be emitted on program exit for any specs that aren't used,
to help you make sure that you are using sensible specs.
=over
=cut
use strict ;
use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ) ;
use Exporter ;
@ISA = qw( Exporter ) ;
@EXPORT_OK = qw(
   debug
   enable_debug
   disable_debug
   debugging
   explicitly_debugging
) ;
%EXPORT_TAGS = (
   'all'   => \@EXPORT_OK,
   'debug' => \@EXPORT_OK,
) ;
$VERSION = 0.1 ;
# TODO:
#=item use
#=item import
#
#In addition to all of the routines and tags that C<use> and C<import> normally
#take (see above), you may also pass in pairwise debugging definitions like
#so:
#
#   use VCP::debug (
#      ":all",
#      DEBUGGING_FOO => "foo,bar",
#   ) ;
#
#Any all caps export import requests are created as subroutines that may well be
#optimized away at compile time if "enable_debugging" has not been called. This
#requires a conspiracy between the author of a module and the author of the main
#program to call enable_debugging I<before> C<use>ing any modules that leverage
#this feature, otherwise compile-time optimizations won't occur.
#
HideShow 10 lines of Pod
=item debug
   debug $foo if debugging $self ;
Emits a line of debugging (a "\n" will be appended).  Use debug_some
to avoid the "\n".  Any undefined parameters will be displayed as
C<E<lt>undefE<gt>>.
=cut
my $dump_undebugged ;
my $reported_specs ;
my @debug_specs ;
my %used_specs ;
my %debugging ;
END {
   $used_specs{'##NEVER_MATCH##'} = 1 ;
   my @unused = grep ! $used_specs{$_}, @debug_specs ;
   warn "vcp: Unused debug specs: ", join( ', ', map "/$_/", @unused ), "\n"
      if @unused ;
   if ( @unused || $dump_undebugged ) {
      my @undebugged = grep {
         my $name = $_ ;
         ! grep $name =~ /$_/i, keys %used_specs
      } map lc $_, sort keys %debugging ;
      if ( @undebugged ) {
         warn "vcp: Undebugged things: ", join( ', ', @undebugged ), "\n" ;
      }
      else {
         warn "vcp: No undebugged things\n" ;
      }
   }
}
sub debug {
   return unless @debug_specs ;
   if ( @_ ) {
      my $t = join( '', map defined $_ ? $_ : "<undef>", @_ ) ;
      if ( length $t ) {
         print STDERR $t, substr( $t, -1 ) eq "\n" ? () : "\n" ;
      }
   }
}
sub debug_some {
   return unless @debug_specs ;
   print STDERR map defined $_ ? $_ : "<undef>", @_ if @_ ;
}
HideShow 14 lines of Pod
=item debugging
   debug "blah" if debugging ;
Returns TRUE if the caller's module is being debugged
   debug "blah" if debugging $self ;
   debug "blah" if debugging $other, $self ; ## ORs the arguments together
Returns TRUE if any of the arguments are being debugged.  Plain
strings can be passed or blessed references.
=cut
sub _report_specs {
   my @report = grep ! /##NEVER_MATCH##/, @debug_specs ;
   print STDERR "Debugging ",join( ', ', map "/$_/", @report ),"\n"
      if @report ;
   $reported_specs = 1 ;
}
sub debugging {
   return undef unless @debug_specs ;
   my $result ;
   my @missed ;
   for my $where ( @_ ? map ref $_ || $_, @_ : scalar caller ) {
      if ( ! exists $debugging{$where} ) {
# print STDERR "missed $where\n" ;
         ## If this is the first miss, then these may not have been reported.
         _report_specs unless $reported_specs ;
         ## We go ahead and evaluate all specs instead of returning when the
         ## first is found so that we can set $used_specs for all specs that
         ## match.
         $debugging{$where} = 0 ;
         for my $spec ( @debug_specs ) {
            next if $spec eq '##NEVER_MATCH##' ;
# print STDERR "   /$spec/:\n" ;
            if ( $where =~ /$spec/i ) {
               $debugging{$where} = 1 ;
               $used_specs{$spec} = 1 ;
               $result = 1 ;
               ## no last: we want to build up %used_specs.  There
               ## aren't usually many specs anyway.
            }
            else {
# print STDERR "   ! /$spec/\n" ;
            }
         }
      }
# print STDERR "$where ", $debugging{$where} ? 'yes' : 'no', "\n" ;
      return 1 if $debugging{$where} ;
   }
   return $result ;
}
HideShow 22 lines of Pod
=item explicitly_debugging
   debug "blah" if explicitly_debugging ;
Returns TRUE if the caller's module is being debugged by a literal match
instead of a pattern match.  This is used when debugging output would normally
be congested with too much crap from a particular subsystem when using a
wildcard debug spec (like ".*"), but you want the ability to turn on debugging
for that subsystem:
   debug "blah" if explicitly_debugging "VCP::Dest::sort" ;
requires an explicit C<VCP::Dest::sort> to be given in the debug specs.
   debug "blah" if explicitly_debugging $self ;
   debug "blah" if explicitly_debugging $other, $self ; ## ORs the args
Returns TRUE if any of the arguments are being debugged.  Plain
strings can be passed or blessed references.
=cut
my %explicitly_debugging ;
sub explicitly_debugging {
   return undef unless @debug_specs ;
   my $result ;
   my @missed ;
   for my $where ( @_ ? map ref $_ || $_, @_ : scalar caller ) {
      if ( ! exists $explicitly_debugging{$where} ) {
# print STDERR "missed $where\n" ;
         ## If this is the first miss, then these may not have been reported.
         _report_specs unless $reported_specs ;
         ## We go ahead and evaluate all specs instead of returning when the
         ## first is found so that we can set $used_specs for all specs that
         ## match.
         $explicitly_debugging{$where} = 0 ;
         for my $spec ( @debug_specs ) {
            next if $spec eq '##NEVER_MATCH##' ;
# print STDERR "   /$spec/:\n" ;
            if ( lc $where eq lc $spec ) {
               $explicitly_debugging{$where} = 1 ;
               $used_specs{$spec} = 1 ;
               $result = 1 ;
               ## no last: we want to build up %used_specs.  There
               ## aren't usually many specs anyway.
            }
            else {
# print STDERR "   ! /$spec/\n" ;
            }
         }
      }
# print STDERR "$where ", $debugging{$where} ? 'yes' : 'no', "\n" ;
      return 1 if $explicitly_debugging{$where} ;
   }
   return $result ;
}
HideShow 6 lines of Pod
=item disable_debug
Disable all debugging.
=cut
sub disable_debug() {
   @debug_specs = () ;
   return ;
}
HideShow 9 lines of Pod
=item enable_debug
   enable_debug ;
   enable_debug( ...debug specs... ) ;
A debug spec is a regular expression that matches the name of a module.
=cut
sub enable_debug {
   my %specs = map { ( $_ => 1 ) } @debug_specs, @_ ;
   my @new_debug_specs = %specs 
      ? keys %specs 
      : qr/^/ ;
   _report_specs
      if $reported_specs && @debug_specs != @new_debug_specs ;
   @debug_specs = map(
      /^what$/i && ( $dump_undebugged = 1 ) ? '##NEVER_MATCH##' : $_,
      @new_debug_specs
   ) ;
   return ;
}
HideShow 14 lines of Pod
=head1 COPYRIGHT
Copyright 2000, Perforce Software, Inc.  All Rights Reserved.
This module and the VCP package are licensed according to the terms given in
the file LICENSE accompanying this distribution, a copy of which is included in
L<vcp>.
=head1 AUTHOR
Barrie Slaymaker <barries@slaysys.com>
=cut
1