package VCP::Debug ; =head1 NAME VCP::Debug - debugging support for VCP =head1 SYNOPSIS =head1 DESCRIPTION =head1 EXPORTS The following functions may be exported: L, L, L L, 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 and C 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 Cing any modules that leverage #this feature, otherwise compile-time optimizations won't occur. # =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 CundefE>. =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" ; } } } my ( $start_time, $last_time ); ## To support undocumented /hires/ debugging sub debug { return unless @debug_specs ; if ( @_ ) { my $t = join( '', map defined $_ ? $_ : "", @_ ) ; if ( length $t ) { if ( defined $start_time ) { my $t = Time::HiRes::time(); printf STDERR "%06.3f +%06.3f ", $t - $start_time, $t - $last_time; $last_time = $t; } print STDERR $t, substr( $t, -1 ) eq "\n" ? () : "\n" ; } } } sub debug_some { return unless @debug_specs ; print STDERR map defined $_ ? $_ : "", @_ if @_ ; } =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 ; } =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 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 ; } =item disable_debug Disable all debugging. =cut sub disable_debug() { @debug_specs = () ; return ; } =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 ) ; # Note: undocumented maintainer feature, and meant to stay that way. # twould be better if this were done using explicitly_debugging "hires", # but that's a bit late since we want the start time ASAP if ( explicitly_debugging "hires" ) { require Time::HiRes; $start_time = Time::HiRes::time(); $last_time = $start_time; printf STDERR "%06.3f +%06.3f vcp: debug timer started\n", 0, 0 } return ; } =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. =head1 AUTHOR Barrie Slaymaker =cut 1