File Coverage

blib/lib/DB/Color.pm
Criterion Covered Total %
statement 61 84 72.6
branch 3 20 15.0
condition 1 12 8.3
subroutine 20 22 90.9
pod 0 3 0.0
total 85 141 60.2


line stmt bran cond sub pod time code
1             package DB::Color;
2              
3 1     1   26755 use 5.008;
  1         3  
  1         55  
4 1     1   5 use strict;
  1         2  
  1         33  
5 1     1   5 use warnings;
  1         6  
  1         29  
6 1     1   661 use DB::Color::Highlight;
  1         2  
  1         28  
7 1     1   804 use DB::Color::Config;
  1         2  
  1         22  
8              
9 1     1   894 use IO::Handle;
  1         6439  
  1         46  
10 1     1   7 use File::Spec::Functions qw(catfile catdir);
  1         2  
  1         52  
11 1     1   6 use Scalar::Util 'dualvar';
  1         2  
  1         82  
12 1     1   6 use File::Find;
  1         2  
  1         276  
13              
14             =head1 NAME
15              
16             DB::Color - Colorize your debugger output
17              
18             =head1 VERSION
19              
20             Version 0.10
21              
22             =cut
23              
24             our $VERSION = '0.10';
25              
26             =head1 SYNOPSIS
27              
28             Put the following in your F<$HOME/.perldb> file:
29              
30             use DB::Color;
31              
32             Then use your debugger like normal:
33              
34             perl -d some_file.pl
35              
36             If you don't want a F<$HOME/.perldb> file, you can do this:
37              
38             perl -MDB::Color -d some_file.pl
39              
40             =head1 DISABLING COLOR
41              
42             If the NO_DB_COLOR environment variable is set to a true value, syntax
43             highlighting will be disabled.
44              
45             =head1 WINDOWS
46              
47             No, sorry. It's a combination of bad Windows support for ANSI escape sequences
48             and bad debugger design.
49              
50             =head1 PERFORMANCE
51              
52             When using the debugger and when you step into something, or continue to a
53             breakpoint in a new file, the debugger may appear to hang for a moment
54             (perhaps a long moment if the file is big) while the file is syntax
55             highlighted and cached. The next time the debugger enters this file, the
56             highlighting should be instantaneous.
57              
58             You can speed up the debugger by using the L program which is
59             included in this distribution. It will pregenerate syntax files for you.
60              
61             Syntax highlighting the code is very slow. As a result, we cache the output
62             files in F<$HOME/.perldbcolor>. This is done by calculating the md5 sum of the
63             file contents. If the file is changed, we get a new sum. This means that
64             syntax highlighting is very slow at first, but every time you hit the same
65             file, assuming its unchanged, the cached version is served first.
66              
67             Note that the cache files are removed after they become 30 (but see config)
68             days old without being used. If you use the debugger regularly, commonly
69             debugged files will load very quickly (assuming they haven't changed).
70              
71             =head1 CONFIGURATION
72              
73             You can optionally configure C by creating a
74             F<$HOME/.perldbcolorrc> configuration file. It looks like this:
75              
76             [core]
77            
78             # the class that will highlight the code
79             highlighter = DB::Color::Highlight
80            
81             # Any cache file not accessed after this number of days is purged
82             cache_max_age = 30
83            
84             # where to put the cache dir
85             cache_dir = /users/ovid/.perldbcolor
86            
87             The above values are more or less the defaults for this module. They are all
88             optional.
89              
90             =head1 ALPHA
91              
92             This is only a proof of concept. In fact, it's fair to say that this code
93             sucks. It's not very configurable and has bugs. It's also going to possibly be
94             a memory hog, as if the debugger wasn't bad enough already.
95              
96             =cut
97              
98             my $config = DB::Color::Config->read( default_rcfile() );
99              
100             my %COLORED;
101             my $DB_BASE_DIR = $config->{core}{cache_dir} || default_base_dir();
102              
103             my $DB_LOG = catfile( $DB_BASE_DIR, 'debug.log' );
104             my $CACHE_MAX_AGE = $config->{core}{cache_max_age} || 30;
105             my $DEBUG;
106              
107             # Not documenting this because I don't guarantee stability, but you can play
108             # with it if you want.
109             if ( $ENV{DB_COLOR_DEBUG} ) {
110             open $DEBUG, '>>', $DB_LOG
111             or die "Cannot open $DB_LOG for appending: $!";
112             $DEBUG->autoflush(1);
113             }
114              
115             my $HIGHLIGHTER_CLASS = $config->{core}{highlighter} || 'DB::Color::Highlight';
116 1     1   8 eval "use $HIGHLIGHTER_CLASS";
  1         1  
  1         34  
117             die $@ if $@;
118              
119             my $HIGHLIGHTER = $HIGHLIGHTER_CLASS->new(
120             {
121             cache_dir => $DB_BASE_DIR,
122             debug_fh => $DEBUG,
123             }
124             );
125              
126             sub DB::afterinit {
127 1     1   7 no warnings 'once';
  1         3  
  1         357  
128 0 0   0 0 0 push @DB::typeahead => "{{v"
129             unless $DB::already_curly_curly_v++;
130             }
131              
132 1     1 0 17 sub default_rcfile { catfile( $ENV{HOME}, '.perldbcolorrc' ) }
133 1     1 0 8 sub default_base_dir { catfile( $ENV{HOME}, '.perldbcolor' ) }
134              
135             sub import {
136 1 50   1   12 return if $ENV{NO_DB_COLOR};
137 1 50       5 if ( 'MSWin32' eq $^O ) {
138 0         0 warn <<"END";
139             DB::Color does not run under Windows because the Windows terminal is too
140             broken to understand terminal color code.
141              
142             DB::Color does not use Win32::Console because the debugger is too broken to be
143             properly extensible.
144             END
145 0         0 return;
146             }
147 1         4 my $old_db = \&DB::DB;
148              
149             my $new_DB = sub {
150 0     0   0 my $lvl = 0;
151 0         0 while ( my ($pkg) = caller( $lvl++ ) ) {
152 0 0 0     0 return if $pkg eq "DB" or $pkg =~ /^DB::/;
153             }
154 0         0 my ( $package, $filename ) = caller;
155 0 0       0 if ($DEBUG) {
156 0         0 print $DEBUG "In package '$package', filename '$filename'\n";
157             }
158              
159             # syntax highlight everything and cache it
160 0   0     0 my $lines = $COLORED{$filename} ||= do {
161 1     1   7 no strict 'refs';
  1         2  
  1         27  
162 1     1   5 no warnings 'uninitialized';
  1         2  
  1         78  
163             [
164 0         0 split /(?<=\n)/ =>
165 0         0 $HIGHLIGHTER->highlight_text( join "" => @{"::_<$filename"} )
166             ];
167             };
168              
169             {
170              
171             # lie to the debugger about what the lines of code are
172 1     1   11 no strict 'refs';
  1         2  
  1         78  
  0         0  
173 0         0 my $line_num = 0;
174 0         0 foreach ( @{"::_<$filename"} ) {
  0         0  
175              
176             # uncomment these to blow your f'in mind
177             #if ( not defined ) {
178             # use Devel::Peek;
179             # warn "line number is $line_num";
180             # Dump($_);
181             #}
182             # The debugger special cases the first value in ::_<$filename.
183             # It's "undef" but sometimes contains some data about the
184             # program. I don't know entirely what it is, but this solves
185             # the "off by one" bug.
186 0 0       0 next unless defined; # thanks Liz! (why does this work?)
187 0         0 my $line = $lines->[ $line_num++ ];
188 0 0       0 next unless defined $line; # happens when $_ = "\n"
189              
190             # XXX Cheap hack to fix
191             # Argument "{\n" isn't numeric in addition (+) at DB/Color.pm line 189.
192 1     1   4 no warnings 'numeric';
  1         2  
  1         96  
193 0         0 my $numeric_value = 0 + $_;
194              
195             # Internally, the debugger uses dualvars for each line of
196             # code. If it's numeric value is 0, then the line is not
197             # breakable. If we don't include this, no lines in the
198             # debugger are breakable.
199 0         0 $_ = dualvar $numeric_value, $line;
200             }
201             }
202 0         0 goto $old_db;
203 1         6 };
204              
205             {
206 1     1   4 no warnings 'redefine';
  1         2  
  1         252  
  1         2  
207 1         4 *DB::DB = $new_DB;
208             }
209              
210 1         12 return;
211             }
212              
213             END {
214             find(
215             sub {
216              
217             # delete empty files or files > $CACHE_MAX_AGE days old
218 1 0 0     176 if ( -f $_ && ( -z _ || -M _ > $CACHE_MAX_AGE ) ) {
      33        
219 0 0       0 unlink($_) or die "Could not unlink '$File::Find::name': $!";
220             }
221             },
222 1     1   654 $DB_BASE_DIR,
223             );
224             # we're not testing for failure as this is a cheap hack to delete empty
225             # directories
226 1 50       102 finddepth( sub { rmdir $_ if -d }, $DB_BASE_DIR );
  1         41  
227             }
228              
229             1;
230              
231             =head1 AUTHOR
232              
233             Curtis "Ovid" Poe, C<< >>
234              
235             =head1 BUGS
236              
237             Please report any bugs or feature requests to C,
238             or through the web interface at
239             L. I will be
240             notified, and then you'll automatically be notified of progress on your bug as
241             I make changes.
242              
243             =head1 SUPPORT
244              
245             You can find documentation for this module with the perldoc command.
246              
247             perldoc DB::Color
248              
249             You can also look for information at:
250              
251             =over 4
252              
253             =item * RT: CPAN's request tracker (report bugs here)
254              
255             L
256              
257             =item * AnnoCPAN: Annotated CPAN documentation
258              
259             L
260              
261             =item * CPAN Ratings
262              
263             L
264              
265             =item * Search CPAN
266              
267             L
268              
269             =back
270              
271             =head1 ACKNOWLEDGEMENTS
272              
273             Thanks to Nick Perez, Liz, and the 2012 Perl Hackathon for helping to overcome
274             some major hurdles with this module.
275              
276             =head1 LICENSE AND COPYRIGHT
277              
278             Copyright 2011 Curtis "Ovid" Poe.
279              
280             This program is free software; you can redistribute it and/or modify it
281             under the terms of either: the GNU General Public License as published
282             by the Free Software Foundation; or the Artistic License.
283              
284             See http://dev.perl.org/licenses/ for more information.
285              
286              
287             =cut
288              
289             1; # End of DB::Color