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 |