package Smart::Comments; use version; $VERSION = qv('1.0.2'); use warnings; use strict; use Carp; use List::Util qw(sum); use Filter::Simple; my $maxwidth = 69; # Maximum width of display my $showwidth = 35; # How wide to make the indicator my $showstarttime = 6; # How long before showing time-remaining estimate my $showmaxtime = 10; # Don't start estimate if less than this to go my $whilerate = 30; # Controls the rate at which while indicator grows my $minfillwidth = 5; # Fill area must be at least this wide my $average_over = 5; # Number of time-remaining estimates to average my $minfillreps = 2; # Minimum size of a fill and fill cap indicator my $forupdatequantum = 0.01; # Only update every 1% of elapsed distance # Synonyms for asserts and requirements... my $require = qr/require|ensure|assert|insist/; my $check = qr/check|verify|confirm/; # Horizontal whitespace... my $hws = qr/[^\S\n]/; # Optional colon... my $optcolon = qr/$hws*;?/; # Automagic debugging as well... my $DBX = '$DB::single = $DB::single = 1;'; # Implement comments-to-code source filter... FILTER { shift; s/\r\n/\n/g; # Handle win32 line endings my $intro = qr/#{3,}/; if (my @unknowns = grep {!/$intro/} @_) { croak "Incomprehensible arguments: @unknowns\n", "in call to 'use Smart::Comments'"; } elsif (@_) { $intro = '(?-x:'.join('|',@_).')(?!\#)'; } # Progress bar on a for loop... s{ ^ $hws* ( (?: [^\W\d]\w*: \s*)? for(?:each)? \s* (?:my)? \s* (?:\$ [^\W\d]\w*)? \s* ) \( ([^;\n]*?) \) \s* \{ [ \t]* $intro \s (.*) \s* $ } { _decode_for($1, $2, $3) }xgem; # Progress bar on a while loop... s{ ^ $hws* ( (?: [^\W\d]\w*: \s*)? (?:while|until) \s* \( .*? \) \s* ) \{ [ \t]* $intro \s (.*) \s* $ } { _decode_while($1, $2) }xgem; # Progress bar on a C-style for loop... s{ ^ $hws* ( (?: [^\W\d]\w*: \s*)? for \s* \( .*? ; .*? ; .*? \) \s* ) \{ $hws* $intro $hws (.*) $hws* $ } { _decode_while($1, $2) }xgem; # Requirements... s{ ^ $hws* $intro [ \t] $require : \s* (.*?) $optcolon $hws* $ } { _decode_assert($1,"fatal") }gemx; # Assertions... s{ ^ $hws* $intro [ \t] $check : \s* (.*?) $optcolon $hws* $ } { _decode_assert($1) }gemx; # Any other smart comment is a simple dump. # Dump a raw scalar (the varname is used as the label)... s{ ^ $hws* $intro [ \t]+ (\$ [\w:]* \w) $optcolon $hws* $ } {Smart::Comments::_Dump(pref=>q{$1:},var=>[$1]);$DBX}gmx; # Dump a labelled scalar... s{ ^ $hws* $intro [ \t] (.+ :) [ \t]* (\$ [\w:]* \w) $optcolon $hws* $ } {Smart::Comments::_Dump(pref=>q{$1},var=>[$2]);$DBX}gmx; # Dump a raw hash or array (the varname is used as the label)... s{ ^ $hws* $intro [ \t]+ ([\@%] [\w:]* \w) $optcolon $hws* $ } {Smart::Comments::_Dump(pref=>q{$1:},var=>[\\$1]);$DBX}gmx; # Dump a labelled hash or array... s{ ^ $hws* $intro [ \t]+ (.+ :) [ \t]* ([\@%] [\w:]* \w) $optcolon $hws* $ } {Smart::Comments::_Dump(pref=>q{$1},var=>[\\$2]);$DBX}gmx; # Dump a labelled expression... s{ ^ $hws* $intro [ \t]+ (.+ :) (.+) } {Smart::Comments::_Dump(pref=>q{$1},var=>[$2]);$DBX}gmx; # Dump an 'in progress' message s{ ^ $hws* $intro $hws* (.+ [.]{3}) \s* $ } {Smart::Comments::_Dump(pref=>qq{$1});$DBX}gmx; # Dump an unlabelled expression (the expression is used as the label)... s{ ^ $hws* $intro $hws* (.*) $optcolon \s* $ } {Smart::Comments::_Dump(pref=>q{$1:},var=>Smart::Comments::_quiet_eval(q{[$1]}));$DBX}gmx; # An empty comment dumps an empty line... s{ ^ $hws* $intro [ \t]+ $ } {warn qq{\n};}gmx; # Anything else is a literal string to be printed... s{ ^ $hws* $intro \s* (.*) } {Smart::Comments::_Dump(pref=>q{$1});$DBX}gmx; }; sub _quiet_eval { local $SIG{__WARN__} = sub{}; return scalar eval shift; } sub _uniq { my %seen; grep { !$seen{$_}++ } @_ } # Converts an assertion to the equivalent Perl code... sub _decode_assert { my ($assertion, $fatal) = @_; # Choose the right signalling mechanism... $fatal = $fatal ? 'die "\n"' : 'warn "\n"'; my $dump = 'Smart::Comments::_Dump'; use Text::Balanced qw(extract_variable extract_multiple); # Extract variables from assertion and enreference any arrays or hashes... my @vars = map { /^$hws*[%\@]/ ? "$dump(pref=>q{ $_ was:},var=>[\\$_], nonl=>1);" : "$dump(pref=>q{ $_ was:},var=>[$_],nonl=>1);" } _uniq extract_multiple($assertion, [\&extract_variable], undef, 1); # Generate the test-and-report code... return qq{unless($assertion){warn "\\n", '### $assertion was not true';@vars; $fatal}}; } # Generate progress-bar code for a Perlish for loop... my $ID = 0; sub _decode_for { my ($for, $range, $mesg) = @_; # Give the loop a unique ID... $ID++; # Rewrite the loop with a progress bar as its first statement... return "my \$not_first__$ID;$for (my \@SmartComments__range__$ID = $range) { Smart::Comments::_for_progress(qq{$mesg}, \$not_first__$ID, \\\@SmartComments__range__$ID);"; } # Generate progress-bar code for a Perlish while loop... sub _decode_while { my ($while, $mesg) = @_; # Give the loop a unique ID... $ID++; # Rewrite the loop with a progress bar as its first statement... return "my \$not_first__$ID;$while { Smart::Comments::_while_progress(qq{$mesg}, \\\$not_first__$ID);"; } # Generate approximate time descriptions... sub _desc_time { my ($seconds) = @_; my $hours = int($seconds/3600); $seconds -= 3600*$hours; my $minutes = int($seconds/60); $seconds -= 60*$minutes; my $remaining; # Describe hours to the nearest half-hour (and say how close to it)... if ($hours) { $remaining = $minutes < 5 ? "about $hours hour".($hours==1?"":"s") : $minutes < 25 ? "less than $hours.5 hours" : $minutes < 35 ? "about $hours.5 hours" : $minutes < 55 ? "less than ".($hours+1)." hours" : "about ".($hours+1)." hours"; } # Describe minutes to the nearest minute elsif ($minutes) { $remaining = "about $minutes minutes"; chop $remaining if $minutes == 1; } # Describe tens of seconds to the nearest ten seconds... elsif ($seconds > 10) { $seconds = int(($seconds+5)/10); $remaining = "about ${seconds}0 seconds"; } # Never be more accurate than ten seconds... else { $remaining = "less than 10 seconds"; } return $remaining; } # Update the moving average of a series given the newest measurement... my %started; my %moving; sub _moving_average { my ($context, $next) = @_; my $moving = $moving{$context} ||= []; push @$moving, $next; if (@$moving >= $average_over) { splice @$moving, 0, $#$moving-$average_over; } return sum(@$moving)/@$moving; } # Recognize progress bars... my @progress_pats = ( # left extending end marker of bar right # anchor bar ("fill") | gap after bar anchor # ====== ======================= === ================= ==== qr{^(\s*.*?) (\[\]\[\]) () \s* (\S?.*)}x, qr{^(\s*.*?) (\(\)\(\)) () \s* (\S?.*)}x, qr{^(\s*.*?) (\{\}\{\}) () \s* (\S?.*)}x, qr{^(\s*.*?) (\<\>\<\>) () \s* (\S?.*)}x, qr{^(\s*.*?) (?>(\S)\2{$minfillreps,}) (\S+) \s{$minfillreps,} (\S.*)}x, qr{^(\s*.*?) (?>(\S)\2{$minfillreps,}) () \s{$minfillreps,} (\S.*)}x, qr{^(\s*.*?) (?>(\S)\2{$minfillreps,}) (\S*) (?=\s*$)}x, qr{^(\s*.*?) () () () \s*$ }x, ); # Clean up components of progress bar (inserting defaults)... sub _prog_pat { for my $pat (@progress_pats) { $_[0] =~ $pat or next; return ($1, $2||"", $3||"", $4||""); } return; } # State information for various progress bars... my (%count, %max, %prev_elapsed, %prev_fraction, %showing); # Animate the progress bar of a for loop... sub _for_progress { my ($mesg, $not_first, $data) = @_; my ($at, $max, $elapsed, $remaining, $fraction); # Update progress bar... if ($not_first) { # One more iteration towards the maximum... $at = ++$count{$data}; $max = $max{$data}; # How long now (both absolute and relative)... $elapsed = time - $started{$data}; $fraction = $max>0 ? $at/$max : 1; # How much change occurred... my $motion = $fraction - $prev_fraction{$data}; # Don't update if count wrapped (unlikely) or if finished # or if no visible change... return unless $not_first < 0 || $at == $max || $motion > $forupdatequantum; # Guestimate how long still to go... $remaining = _moving_average $data, $fraction ? $elapsed/$fraction-$elapsed : 0; } # If first iteration... else { # Start at the beginning... $at = $count{$data} = 0; # Work out where the end will be... $max = $max{$data} = $#$data; # Start the clock... $started{$data} = time; $elapsed = 0; $fraction = 0; # After which, it will no longer be the first iteration. $_[1] = 1; # $not_first } # Remember the previous increment fraction... $prev_fraction{$data} = $fraction; # Now draw the progress bar (if it's a valid one)... if (my ($left, $fill, $leader, $right) = _prog_pat($mesg)) { # Insert the percentage progress in place of a '%'... s/%/int(100*$fraction).'%'/ge for ($left, $leader, $right); # Work out how much space is available for the bar itself... my $fillwidth = $showwidth - length($left) - length($right); # But no less than the prespecified minimum please... $fillwidth = $minfillwidth if $fillwidth < $minfillwidth; # Make enough filler... my $totalfill = $fill x $fillwidth; # How big is the end of the bar... my $leaderwidth = length($leader); # Truncate where? my $fillend = $at==$max ? $fillwidth : $fillwidth*$fraction-$leaderwidth; $fillend = 0 if $fillend < 0; # Now draw the bar, using carriage returns to overwrite it... print STDERR "\r", " "x$maxwidth, "\r", $left, sprintf("%-${fillwidth}s", substr($totalfill, 0, $fillend) . $leader), $right; # Work out whether to show an ETA estimate... if ($elapsed >= $showstarttime && $at < $max && ($showing{$data} || $remaining && $remaining >= $showmaxtime) ) { print STDERR " (", _desc_time($remaining), " remaining)"; $showing{$data} = 1; } # Close off the line, if we're finished... print STDERR "\r", " "x$maxwidth, "\n" if $at >= $max; } } my %shown; my $prev_length = -1; # Animate the progress bar of a while loop... sub _while_progress { my ($mesg, $not_first_ref) = @_; my $at; # If we've looped this one before, recover the current iteration count... if ($$not_first_ref) { $at = ++$count{$not_first_ref}; } # Otherwise set the iteration count to zero... else { $at = $count{$not_first_ref} = 0; $$not_first_ref = 1; } # Extract the components of the progress bar... if (my ($left, $fill, $leader, $right) = _prog_pat($mesg)) { # Replace any '%' with the current iteration count... s/%/$at/ge for ($left, $leader, $right); # How much space is there for the progress bar? my $fillwidth = $showwidth - length($left) - length($right); # Make it at least the prespecified minimum amount... $fillwidth = $minfillwidth if $fillwidth < $minfillwidth; # How big is the end of the bar? my $leaderwidth = length($leader); # How big does that make the bar itself (use reciprocal growth)... my $length = int(($fillwidth-$leaderwidth) *(1-$whilerate/($whilerate+$at))); # Don't update if the picture would look the same... return if length $fill && $prev_length == $length; # Otherwise, remember where we got to... $prev_length = $length; # And print the bar... print STDERR "\r", " "x$maxwidth, "\r", $left, sprintf("%-${fillwidth}s", substr($fill x $fillwidth, 0, $length) . $leader), $right; } } # Vestigal (I think)... #sub Assert { # my %arg = @_; # return unless $arg{pass} #} use Data::Dumper 'Dumper'; # Dump a variable and then reformat the resulting string more prettily... sub _Dump { my %args = @_; my ($pref, $varref, $nonl) = @args{qw(pref var nonl)}; # Handle timestamps... my (undef, $file, $line) = caller; $pref =~ s/<(?:now|time|when)>/scalar localtime()/ge; $pref =~ s/<(?:here|place|where)>/"$file", line $line/g; # Add a newline? my $nl = $nonl ? "" : "\n"; # Handle a prefix with no actual variable... if ($pref && !defined $varref) { $pref =~ s/:$//; warn "$nl### $pref\n"; return; } # Set Data::Dumper up for a tidy dump and do the dump... local $Data::Dumper::Quotekeys = 0; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Indent = 2; my $dumped = Dumper $varref; # Clean up the results... $dumped =~ s/\$VAR1 = \[\n//; $dumped =~ s/\s*\];\s*$//; $dumped =~ s/\A(\s*)//; # How much to shave off and put back on each line... my $indent = length $1; my $outdent = " " x (length($pref) + 1); # Report "inside-out" and "flyweight" objects more cleanly... $dumped =~ s{bless[(] do[{]\\[(]my \$o = undef[)][}], '([^']+)' [)]} {}g; # Adjust the indents... $dumped =~ s/^[ ]{$indent}([ ]*)/### $outdent$1/gm; # Print the message... warn "$nl### $pref $dumped\n$nl"; } 1; # Magic true value required at end of module __END__ =head1 NAME Smart::Comments - Comments that do more than just sit there =head1 VERSION This document describes Smart::Comments version 1.0.2 =head1 SYNOPSIS use Smart::Comments; my $var = suspect_value(); ### $var ### got: $var ### Now computing value... # and when looping: for my $big_num (@big_nums) { ### Factoring... done factor($big_num); } while ($error > $tolerance) { ### Refining---> done refine_approximation() } for (my $i=0; $i<$MAX_INT; $i++) { ### Working===[%] done do_something_expensive_with($i); } =head1 DESCRIPTION Smart comments provide an easy way to insert debugging and tracking code into a program. They can report the value of a variable, track the progress of a loop, and verify that particular assertions are true. Best of all, when you're finished debugging, you don't have to remove them. Simply commenting out the C line turns them back into regular comments. Leaving smart comments in your code is smart because if you needed them once, you'll almost certainly need them again later. =head1 INTERFACE All smart comments start with three (or more) C<#> characters. That is, they are regular C<#>-introduced comments whose first two (or more) characters are also C<#>'s. =head2 Using the Module The module is loaded like any other: use Smart::Comments; When loaded it filters the remaining code up to the next: no Smart::Comments; directive, replacing any smart comments with smart code that implements the comments behaviour. You can also specify particular levels of smartness, by including one or more markers as arguments to the C: use Smart::Comments '###', '####'; These arguments tell the module to filter only those comments that start with the same number of C<#>'s. So the above C statement would "activate" any smart comments of the form: ### Smart... #### Smarter... but not those of the form: ##### Smartest... This facility is useful for differentiating progress bars (see L), which should always be active, from debugging comments (see L), which should not: #### Debugging here... for (@values) { ### Progress: 0... 100 do_stuff(); } Note that, for simplicity, all smart comments described below will be written with three C<#>'s; in all such cases, any number of C<#>'s greater than three could be used instead. =head2 Debugging via Comments The simplest way to use smart comments is for debugging. The module supports the following forms, all of which print to C: =over =item C<< ### LABEL : EXPRESSION >> The LABEL is any sequence of characters up to the first colon. The EXPRESSION is any valid Perl expression, including a simple variable. When active, the comment prints the label, followed by the value of the expression. For example: ### Expected: 2 * $prediction ### Got: $result prints: ### Expected: 42 ### Got: 13 =item C<< ### EXPRESSION >> The EXPRESSION is any valid Perl expression, including a simple variable. When active, the comment prints the expression, followed by the value of the expression. For example: ### 2 * $prediction ### $result prints: ### 2 * $prediction: 42 ### $result: 13 =item C<< ### TEXT... >> The TEXT is any sequence of characters that end in three dots. When active, the comment just prints the text, including the dots. For example: ### Acquiring data... $data = get_data(); ### Verifying data... verify_data($data); ### Assimilating data... assimilate_data($data); ### Tired now, having a little lie down... sleep 900; would print: ### Acquiring data... ### Verifying data... ### Assimilating data... ### Tired now, having a little lie down... as each phase commenced. This is particularly useful for tracking down precisely where a bug is occurring. It is also useful in non-debugging situations, especially when batch processing, as a simple progress feedback mechanism. Within a textual smart comment you can use the special sequence C<< >> (or C<<