File Coverage

lib/Devel/Comments.pm

Criterion	Covered	Total	%
statement	268	299	89.6
branch	63	106	59.4
condition	26	44	59.0
subroutine	30	34	88.2
pod	0	7	0.0
total	387	490	78.9

package Devel::Comments;

######## use section ########
use 5.008;
use strict;
use warnings;

# Please see the file VERSIONS.
use version 0.77; our $VERSION = qv('1.1.4');

# original S::C (originally used here)
use Carp;
use List::Util qw(sum);
use Filter::Simple;

# collected S::C (originally distributed in code)
use Text::Balanced              # Extract delimited text sequences from strings
    qw( extract_variable extract_multiple );

use Data::Dumper 'Dumper';

# debug only

#~ $DB::single=1;                                                           #~
#~ use feature 'say';                  # disable in production              #~
#~ use Smart::Comments '###';       # playing with fire;     debug only     #~
#~ use Smart::Comments '####';      # playing with fire;     debug only     #~
#~ use Smart::Comments '#####';     # playing with fire;     debug only     #~

######## / use ########

#~ say '---| Devel::Comments at line ', __LINE__;                           #~

######## pseudo-constants section ########

# time and space constants
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...    (perl -d debugger)
# Someone has to tell me why *two* assignments here (??)
my $DBX                 = '$DB::single = $DB::single = 1;';

# 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,
);

# new with DC
my $join_up             = qq{ };    # used to join replacement code strings

######## / pseudo-constants ########

######## pseudo-global variables section ########

## original S::C stuff

# Unique ID assigned to each loop; incremented when assigned
#   See: for_progress, while_progress
my $ID                  = 0;

#   See: for_progress
my %started             ;

#   See: _moving_average
my %moving              ;

# State information for various progress bars...
#   See: for_progress, while_progress
my (%count, %max, %prev_elapsed, %prev_fraction, %showing);

#   See: while_progress
my $prev_length = -1;


## new with DC

# Unique ID assigned to each use of DC
#   (strictly, per-import)
#
# Note that since source filtering is applied from use line down to EOF
#   or (perhaps) 'no Devel::Comments;', a given filtering action is neither
#   strictly per-package nor per-file.
#
# See _get_new_caller_id()
#
my $new_caller_id   = 1;            # Will be assigned to "this" use

# Store per-use (per-fileish) state info
#   for access by external routines called by replacement code
my %state_of            ;
#   SomeCaller      => {            # $caller_id is primary key
#       -outfh                      # desired output filehandle
#       -tell           => {        # stored tell() of...
#           -outfh                  # ... $outfh
#           -stdout                 # ... *STDOUT
#       },
#       -caller         => {        # stored caller()...
#           -name                   # ...[0] (= 'SomeCaller')
#           -file                   # ...[1]
#           -line                   # ...[2]
#       },
#   },
#   AnotherCaller...

######## / pseudo-global variables ########

#----------------------------------------------------------------------------#


######## INTERNAL ROUTINE ########
#
#   my $caller_id   = _get_new_caller_id();     # unique per-use
#
# Purpose   : Assign a unique ID to each filtering operation
# Parms     : none
# Reads     : $new_caller_id
# Returns   : $caller_id        scalar integer
# Writes    : $new_caller_id
# Throws    : never
# See also  : %state_of
#
# Called once per use line by _prefilter(). Thereafter, $caller_id is either
#   passed along or interpolated and inserted into client code.
# Strictly, $caller_id is unique neither to calling package nor file;
#   it is assigned whenever Filter::Simple::FILTER calls _prefilter(),
#   which should happen once per use. So, its scope within client code is:
#       from: use Devel::Comments
#         to:  no Devel::Comments
#   ...possibly crossing package boundaries.
#
sub _get_new_caller_id {
    return $new_caller_id++;
};
######## /_get_new_caller_id ########

######## INTERNAL ROUTINE ########
#
#   my $outfh       = _get_outfh($caller_id);   # retrieve from %state_of
#
# Purpose  : Retrieve output filehandle associated with some caller
# Parms    : $caller_id
# Reads    : %state_of
# Returns  : stored filehandle for all smart output
# Writes   : none
# Throws   : dies if no arg passed
# See also : _put_outfh(), _get_new_caller_id()
#
sub _get_outfh {
    my $caller_id       = shift
        or die   q{Devel::Comments: }  # called with no arg
            ,    q{Internal error: }
            ,    q{_get_outfh called with no or false arg. }
            ,    $!
            ;
    defined $state_of{$caller_id}
        or die   q{Devel::Comments: }  # called with bad id
            ,    q{Internal error: }
            ,   qq{$caller_id not defined in }
            ,    q{%state_of. }
            ,    $!
            ;

    defined $state_of{$caller_id}{-outfh}
        or die   q{Devel::Comments: }  # no $outfh found
            ,    q{Internal error: }
            ,    q{No output filehandle found in %state_of }
            ,   qq{for $caller_id. }
            ,    $!
            ;

    return $state_of{$caller_id}{-outfh};

};
######## /_do_ ########

######## INTERNAL ROUTINE ########
#
#   _init_state({               # initialize $state_of this caller
#       -outfh          => $outfh,
#       -caller_id      => $caller_id,
#   });
#
# Purpose   : Initialize state; store $outfh and avoid warnings later
# Parms     : hashref
#           :   -caller_id      $caller_id
#           :   -outfh          $outfh
# Reads     : none
# Returns   : 1
# Writes    : %state_of
# Throws    : never
# See also  : _prefilter(), _put_state()
#
# Call once per use from _prefilter() only.
# This is important, lest we get confused about which stack frame is wanted.
#
sub _init_state {
    my $href        = shift;

    my $caller_id       = $href->{-caller_id}
        or die   q{Devel::Comments: }  # called with no -caller_id
            ,    q{Internal error: }
            ,    q{-caller_id not passed in call to _init_state(). }
            ,    $!
            ;

    my $outfh           = $href->{-outfh}
        or die   q{Devel::Comments: }  # called with no -outfh
            ,    q{Internal error: }
            ,    q{-outfh not passed in call to _init_state(). }
            ,    $!
            ;

    # frame
    #   0       _prefilter
    #   1       FILTER
    #   2       Filter::Simple
    #   3       actual use-line caller
    my $frame           = 3;
    my @caller          = caller($frame);

#   my $caller_name     = $caller[0];
    my $caller_file     = $caller[1];
    my $caller_line     = $caller[2];
    my $caller_sub      = $caller[3];   # TODO?: Test if we have the right caller...

    # Stash $outfh as $caller_id-dependent state info
    $state_of{$caller_id}{-outfh}           = $outfh;

    # It may not matter *what* you initialize these to...
    $state_of{$caller_id}{-tell}{-outfh}    = tell $outfh;
    $state_of{$caller_id}{-tell}{-stdout}   = tell (*STDOUT);
    $state_of{$caller_id}{-caller}{-file}   = $caller_file;
    $state_of{$caller_id}{-caller}{-line}   = $caller_line;

#~ ### ...Leaving _init_state()...                                          #~
#~ ### %state_of                                                            #~

    return 1;
};
######## /_init_state ########

######## INTERNAL ROUTINE ########
#
#   $prefilter      = _prefilter(@_);       # Handle arguments to FILTER
#
# Purpose   : Handle arguments and do pseudo-global and per-use setup
# Parms     : @_
# Reads     : %ENV
# Returns   : hashref       (or 0 to abort filtering entirely)
#           :   -intro          $intro
#           :   -caller_id      $caller_id
# Writes    : %state_of
# Throws    : carp() if passed a bad arg in @_
# See also  : ____
#
# Don't want to be fussy about the order of args passed on the use line,
#   so each bit roots through all of them looking for what it wants.
#
sub _prefilter {

#~ say '---| Devel::Comments at line ', __LINE__;                           #~

    shift;                          # Don't need our own package name
    s/\r\n/\n/g;                    # Handle win32 line endings

    my $caller_id       = _get_new_caller_id();     # unique per-use

    # Default introducer pattern...
    my $intro       = qr/#{3,}/;
    my @intros      ;

    # Get filehandle

    my $fh_seen         = 0;            # no filehandle seen yet
    my $outfh           = undef;        # don't assign it first; see open()
    my $out_filename    = "$0.log";     # default
    my $arg             ;               # trial from @_
    my %packed_args     ;               # possible args packed into a hashref

    # Dig through the args to see if one is a hashref
    GETHREF:
    for my $i ( 0..$#_ ) {          # will need the index in a bit
        $arg            = $_[$i];   # look but don't take

        if ( ref $arg ) {               # some kind of reference
            my $stringy     = sprintf $arg;
            if ( $stringy =~ /HASH/ ) { # looks like a hash ref
                %packed_args    = %$arg;
                if ( defined $packed_args{-file} ) {
                    $out_filename   = $packed_args{-file};
                };  # else if undef, use default
                splice @_, $i;          # remove the parsed arg
#~ say '$out_filename: ', $out_filename;                                    ~#
                open $outfh, '>', $out_filename
                    or die "Devel::Comments: "
                        ,  "Can't open $out_filename to write."
                        , $!
                        ;
                # Autoflush $outfh
                my $prev_fh         = select $outfh;
                local $|            = 1;                # autoflush
                select $prev_fh;



#~ say $outfh '... Just after opening $outfh ...';                          #~
#~ say $outfh '$outfh: ', $outfh;                                           #~
            };
        };

#~ return 0;                                                                #~
    };      # /GETHREF

    # Dig through the args to see if one is a filehandle
    SETFH:
    for my $i ( 0..$#_ ) {          # will need the index in a bit
        $arg            = $_[$i];   # look but don't take

        # Is $arg defined by vanilla Smart::Comments?
        if ( $arg eq '-ENV' || (substr $arg, 0, 1) eq '#' ) {
            next SETFH;             # no, keep looking
        };
#~        print 'Mine: >', $arg, "<\n";                                     #~

        # Vanilla doesn't want to see it, so remove from @_
        splice @_, $i;

        # Is it a writable filehandle?
        if ( not -w $arg ) {
            carp   q{Not a writable filehandle: }
                . qq{$arg}
                .  q{ in call to 'use Devel::Comments'.}
                ;
        }                           # and keep looking
        else {
            $outfh      = $arg;
            last SETFH;             # found, so we're done looking
        };
    };      # /SETFH

    if (!$outfh) {
        $outfh          = *STDERR;      # default
    };

#~ say STDERR '... About to _init_state() ...';                             #~
#~ say STDERR '$outfh: ', $outfh;                                           #~
    _init_state({               # initialize $state_of this caller
        -outfh          => $outfh,
        -caller_id      => $caller_id,
    });

#### ...In prefilter()...
#### %state_of

    ## done with the new-for-DC setup


    # Handle intros and env args...
    while (@_) {
        my $arg = shift @_;

   if ($arg eq '-ENV') {
       my $env_filters = _handle_env();
       return 0 if !$env_filters;  # i.e. if no filtering ABORT
       unshift @_, @{$env_filters};
   }
        else {
            push @intros, $arg;
        }
    }

    if (my @unknowns = grep {!/$intro/} @intros) {
        croak "Incomprehensible arguments: @unknowns\n",
              "in call to 'use Devel::Comments'";
    }

    # Make non-default introducer pattern...
    if (@intros) {
        $intro = '(?-x:'.join('|',@intros).')(?!\#)';
    }

#~ say $outfh '... Leaving _prefilter() ...';                               #~
    return {
        -intro          => $intro,
        -caller_id      => $caller_id,
    };
};
######## /_prefilter ########

######## INTERNAL ROUTINE ########
# _handle_env
#
# Purpose  : Deal with environment variables
# Params   : *none*
# Reads    : %ENV
# Returns  : nothing => no environment variable set
#          : array ref => a list of things to put onto
#            the "intros" array.
sub _handle_env {
    # First look to see if the Devel_Comments variable is set, if so
    # process it and return.
    my $dc_env = $ENV{Devel_Comments};
    if ($dc_env) {
        return _handle_dc_env($dc_env);
    }
    # Now check the multitude of smart comments environment variables.
    my $sc_env =
         $ENV{Smart_Comments}
      || $ENV{SMART_COMMENTS}
      || $ENV{SmartComments}
      || $ENV{SMARTCOMMENTS};
    if ($sc_env) {
        return _handle_sc_env($sc_env);
    }

    return;
}
######## /_handle_env ########

######## INTERNAL ROUTINE ########
# _handle_dc_env
#
# Purpose  : To process the devel comments environment variable.
# Params   : A scalar containing the value of the environment variable
# Returns  : An array ref containing 0 or more ???s
#            - if the env var just contains a 1 a ref to an empty
#              array is returned.
#            - otherwise the variable is split on space or (space
#              surrounded) colons.
sub _handle_dc_env {
    my $env = shift;
    # For now we can just do the same thing as for a smart comments
    # env variable.  In future it would be possible to handle devel
    # comments environment variables differently.
    return _handle_sc_env($env);
}

######## /_handle_dc_env ########

######## INTERNAL ROUTINE ########
# _handle_sc_env
#
# Purpose  : To process the devel comments environment variable.
# Params   : A scalar containing the value of the environment variable
# Returns  : An array ref containing 0 or more ???s
#            - if the env var just contains a 1 a ref to an empty
#              array is returned.
#            - otherwise the variable is split on space or (space
#              surrounded) colons.
sub _handle_sc_env {
    my $env = shift;
    if ( $env !~ m{\A \s* 1 \s* \Z}xms ) {
        return [ split m{\s+|\s*:\s*}xms, $env ];
    }
    return [];
}

######## /_handle_sc_env ########

sub import;     # FORWARD

######## EXTERNAL SUB CALL ########
#
# Purpose  : Rewrite caller's smart comments into code
# Parms    : @_     : The split use line, with $_[0] being *this* package
#          : $_     : Caller's entire source code to be filtered
# Reads    : %ENV, %state_of
# Returns  : $_     : Filtered code
# Writes   : %state_of
# Throws   : never
# See also : Filter::Simple, _prefilter()
#
# Implement comments-to-code source filter.
#
# This is not a subroutine but a call to Filter::Simple::FILTER
#   with its single argument being its following block.
#
# The block may be thought of as an import routine
#   which is passed @_ and $_ and must return the filtered code in $_
#
# Note (if our module is invoked properly via use):
# From caller's viewpoint, use operates as a BEGIN block,
#   including all our-module inline code and this call to FILTER;
#       while filtered-in calls to our-module subs take place at run time.
# From our viewpoint, our inline code, including FILTER,
#   is run after any BEGIN or use in our module;
#       and filtered-in subs may be viewed
#       as if they were externally called subs in a normal module.
# Because FILTER is called as part of a constructed import routine,
#   it executes every time our module is use()-ed,
#   although other inline code in our module only executes one time only,
#   when first use()-ed.
#
# See "How it works" in Filter::Simple's POD.
#
sub FILTERx {}; # dummy sub only to appear in editor's symbol table
#
FILTER {
    ##### |--- Start of filter ---|
    ##### @_
    ##### $_
#~ say "---| Source to be filtered:\n", $_, '|--- END SOURCE CODE';         #~

    my $prefilter       = _prefilter(@_);       # Handle arguments to FILTER
    return 0 if !$prefilter;                    # i.e. if no filtering ABORT

    my $intro           = $prefilter->{-intro};         # introducer pattern
    my $caller_id       = $prefilter->{-caller_id};     # unique per-use

    # Preserve DATA handle if any...
    if (s{ ^ __DATA__ \s* $ (.*) \z }{}xms) {
        no strict qw< refs >;
        my $DATA = $1;
        open *{caller(1).'::DATA'}, '<', \$DATA or die "Internal error: DATA. $!";
    }

#~ say '---| Devel::Comments at line ', __LINE__;                           #~

    # Progress bar on a for loop...
    # Calls _decode_for()
    s{ ^ $hws* ( (?: [^\W\d]\w*: \s*)? for(?:each)? \s* (?:my)? \s* (?:\$ [^\W\d]\w*)? \s* ) \( ([^;\n]*?) \) \s* \{
            [ \t]* $intro \s (.*) \s* $
     }
     { _decode_for($caller_id, $1, $2, $3) }egmx;

    # Progress bar on a while loop...
    # Calls _decode_while()
    s{ ^ $hws* ( (?: [^\W\d]\w*: \s*)? (?:while|until) \s* \( .*? \) \s* ) \{
            [ \t]* $intro \s (.*) \s* $
     }
     { _decode_while($caller_id, $1, $2) }egmx;

    # Progress bar on a C-style for loop...
    # Calls _decode_while()
    s{ ^ $hws* ( (?: [^\W\d]\w*: \s*)? for \s* \( .*? ; .*? ; .*? \) \s* ) \{
            $hws* $intro $hws (.*) $hws* $
     }
     { _decode_while($caller_id, $1, $2) }egmx;

    # Requirements...
    # Calls _decode_assert()
    s{ ^ $hws* $intro [ \t] $require : \s* (.*?) $optcolon $hws* $ }
     { _decode_assert($caller_id, $1,"fatal") }egmx;

    # Assertions...
    # Calls _decode_assert()
    s{ ^ $hws* $intro [ \t] $check : \s* (.*?) $optcolon $hws* $ }
     { _decode_assert($caller_id, $1) }egmx;

    # Any other smart comment is a simple dump.
    # The replacement code in each case consists mainly
    #   of a call to Dump_for().
    # But WATCH OUT for subtle differences!

    # Dump a raw scalar (the varname is used as the label)...
    s{ ^ $hws* $intro [ \t]+ (\$ [\w:]* \w) $optcolon $hws* $ }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*    -caller_id   => $caller_id,                                  *,
        qq*    -prefix      =>  q{$1:},                                     *,
        qq*    -varref      =>   [$1],                                      *,
        qq* );$DBX                                                          *,
     }egmx;

    # Dump a labelled scalar...
    s{ ^ $hws* $intro [ \t] (.+ :) [ \t]* (\$ [\w:]* \w) $optcolon $hws* $ }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*     -caller_id  => $caller_id,                                  *,
        qq*     -prefix     =>  q{$1},                                      *,
        qq*     -varref     =>   [$2],                                      *,
        qq* );$DBX                                                          *,
     }egmx;

    # Dump a raw hash or array (the varname is used as the label)...
    s{ ^ $hws* $intro [ \t]+ ([\@%] [\w:]* \w) $optcolon $hws* $ }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*    -caller_id   => $caller_id,                                  *,
        qq*    -prefix      =>  q{$1:},                                     *,
        qq*    -varref      => [\\$1],                                      *,
        qq* );$DBX                                                          *,
     }egmx;

    # Dump a labelled hash or array...
    s{ ^ $hws* $intro [ \t]+ (.+ :) [ \t]* ([\@%] [\w:]* \w) $optcolon $hws* $ }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*    -caller_id   => $caller_id,                                  *,
        qq*    -prefix      =>  q{$1},                                      *,
        qq*    -varref      => [\\$2],                                      *,
        qq* );$DBX                                                          *,
     }egmx;

    # Dump a labelled expression...
    s{ ^ $hws* $intro [ \t]+ (.+ :) (.+) }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*    -caller_id   => $caller_id,                                  *,
        qq*    -prefix      =>  q{$1},                                      *,
        qq*    -varref      =>   [$2],                                      *,
        qq* );$DBX                                                          *,
     }egmx;

    # Dump an 'in progress' message
    s{ ^ $hws* $intro $hws* (.+ [.]{3}) $hws* $ }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*    -caller_id   => $caller_id,                                  *,
        qq*    -prefix      => qq{$1},                                      *,
        qq* );$DBX                                                          *,
     }egmx;

    # Dump an unlabelled expression (the expression is used as the label)...
    # Note inserted call to quiet_eval()
    s{ ^ $hws* $intro $hws* (.*) $optcolon $hws* $ }
     { join $join_up,
        qq* Devel::Comments::Dump_for(                                 *,
        qq*    -caller_id   => $caller_id,                                  *,
        qq*    -prefix      =>  q{$1:},                                     *,
        qq*    -varref      => Devel::Comments::quiet_eval( q{[$1]} ), *,
        qq* );$DBX                                                          *,
     }egmx;

# This doesn't work as expected, don't know why
# It can't help to warn instead of print
#   # An empty comment dumps an empty line...
#   # Inserts call to warn()
#   s{ ^ $hws* $intro [ \t]+ $ }
#    {warn qq{\n};}gmx;

# This is never needed; for some reason it's caught by "unlabeled expression"
# Strictly speaking, it's an undocumented feature
#   # Anything else is a literal string to be printed...
#   # Inserts call to Dump_for()
#   s{ ^ $hws* $intro $hws* (.*) }
#    {Devel::Comments::Dump_for(-prefix=>q{$1});$DBX}gmx;

    ##### |--- End of filter ---|
    ##### @_
    ##### $_
#~ say "---| Source after filtering:\n", $_, '|--- END SOURCE CODE';        #~

};
######## /FILTER ########

######## IMPORT ROUTINE ########
#
# Purpose  : dummy for now
# Parms    : ____
# Reads    : ____
# Returns  : ____
# Writes   : ____
# Throws   : ____
# See also : ____
#
# The "normal" import routine must be declared
#   *before* the call to FILTER.
# However, Filter::Simple will call import()
#   *after* applying FILTER to caller's source code.
#
sub import {

#~ say '---| Devel::Comments at line ', __LINE__;                           #~

};
######## /import ########

#============================================================================#

######## EXTERNAL ROUTINE ########
#
#   $return     = quiet_eval($codestring);      # string eval, no errors
#
# Purpose  : String eval some code and suppress any errors
# Parms    : $codestring    : Arbitrary client code
# Reads, Returns, Writes    : Whatever client code does
# Throws   : never, ever
# See also : FILTER # Dump an unlabelled expression
#
sub quiet_eval {
    local $SIG{__WARN__} = sub{};
    return scalar eval shift;
};
######## /quiet_eval ########

######## INTERNAL ROUTINE ########
#
#   $quantity   = _uniq(@list);     # short
#
# Purpose  : ____
# Parms    : any @list
# Reads    : none
# Returns  : scalar quantity of unique elements
# Writes   : none
# Throws   : never
# See also : _decode_assert()
#
#
sub _uniq {
    my %seen;
    grep { !$seen{$_}++ } @_
};
######## /_uniq ########

######## REPLACEMENT CODE GENERATOR ########
#
#   $codestring     = _decode_assert( $caller_id, $assertion, $signal_flag);
#
# Purpose   : Converts an assertion to the equivalent Perl code.
# Parms     : $caller_id
#           : $assertion    : text of assertion
#           : $signal_flag  : TRUE to die
# Reads     : %state_of
# Returns   : Replacement code string
# Writes    : none
# Throws    : never itself but generated code may die
# See also  : FILTER # Requirements, # Assertions
#
# Generates three snippets of code (in reverse order):
#   $signal_code                # real die or sim warn
#   @vardump_code_lines         # Dumped variable(s)
#   $report_code                # entire replacement codestring,
#                                   including previous two and $assertion
#
sub _decode_assert {
    my $caller_id       = shift;
    my $assertion       = shift;
    my $signal_flag     = shift;

    my $frame           = 0;    # replacement code calls Warn_for() directly

    my $Dump_for    = 'Devel::Comments::Dump_for';
    my $Print_for   = 'Devel::Comments::Print_for';
    my $Warn_for    = 'Devel::Comments::Warn_for';

    # Choose the right signalling mechanism
    #   after Warn_for()...
    my $signal_code
        = $signal_flag
        ?  q* die "\n"                          *   # ...then real die
        : qq* $Print_for( $caller_id, "\n" )    *   # ...then newline
        ;

    # Extract variables from assertion and enreference any arrays or hashes...
    my @vardump_code_lines
        = map {
              /^$hws*[%\@]/                     # sigil found
            ?   join $join_up,
                    qq* $Dump_for(                          *,
                    qq*     -caller_id  => $caller_id,      *,
                    qq*     -prefix     => q{    $_ was:},  *,
                    qq*     -varref     => [\\$_],          *,  # enreference
                    qq*     -no_newline => 1                *,
                    qq* );                                  *,
            :   join $join_up,
                    qq* $Dump_for(                          *,
                    qq*     -caller_id  => $caller_id,      *,
                    qq*     -prefix     => q{    $_ was:},  *,
                    qq*     -varref     => [$_],            *,  # don't enref
                    qq*     -no_newline => 1                *,
                    qq* );                                  *,
            ;
        }
        _uniq extract_multiple($assertion, [\&extract_variable], undef, 1)
        ## end of map expression
    ;
    ## end of assignment

    # Generate the test-and-report code...
    my $report_code     = join $join_up,
        qq* unless($assertion) {                    *,
        qq*     $Warn_for(                          *,
        qq*         $caller_id,                     *,  # $caller_id
        qq*         $frame,                         *,  # $frame
        qq*         "\\n",                          *,  # @text to print
        qq*         q{### $assertion was not true}  *,  #   more @text
        qq*     );                                  *,
        qq*     @vardump_code_lines;                *,  # call Dump_for
        qq*     $signal_code                        *,  # maybe die
        qq* }                                       *,
    ;
    ## end of assignment
#~ $DB::single=1;                                                           #~
    return $report_code;
};
######## /_decode_assert ########

######## REPLACEMENT CODE GENERATOR ########
#
#   $codestring     = _decode_for($for, $range, $mesg);
#
# Purpose  : Generate progress-bar code for a Perlish for loop.
# Parms    : $for   :
#          : $range :
#          : $mesg  :
# Reads    : ____
# Returns  : Replacement code string
# Writes   : $ID
# Throws   : never
# See also : for_progress()
#
sub _decode_for {
    my $caller_id       = shift;
    my $for             = shift;
    my $range           = shift;
    my $mesg            = shift;

    # Give the loop a unique ID...
    $ID++;

    # Rewrite the loop with a progress bar as its first statement...
    my $report_code     = join qq{\n},
        qq* my \$not_first__$ID;                                    *,
        qq* $for (my \@SmartComments__range__$ID = $range) {        *,
        qq*     Devel::Comments::for_progress( $caller_id,          *,
        qq*         qq{$mesg},                                      *,
        qq*         \$not_first__$ID,                               *,
        qq*         \\\@SmartComments__range__$ID                   *,
        qq*     );                                                  *,
            # closing brace found somewhere in client code
    ;
    ## end of assignment

### _decode_for code : $report_code
    return $report_code;
};
######## /_decode_for ########

######## REPLACEMENT CODE GENERATOR ########
#
#   _decode_while($while, $mesg);       # short
#
# Purpose   : Generate progress-bar code for a Perlish while loop.
# Parms     : $while :
#           : $mesg  :
# Reads     : ____
# Returns  : Replacement code string
# Writes    : $ID
# Throws    : ____
# See also  : while_progress()
#
sub _decode_while {
    my $caller_id       = shift;
    my $while           = shift;
    my $mesg            = shift;

    # Give the loop a unique ID...
    $ID++;

    # Rewrite the loop with a progress bar as its first statement...
    my $report_code     = join qq{\n},
        qq* my \$not_first__$ID;                                    *,
        qq* $while {                                                *,
        qq*     Devel::Comments::while_progress( $caller_id,        *,
        qq*         qq{$mesg},                                      *,
        qq*         \\\$not_first__$ID                              *,
        qq*     );                                                  *,
            # closing brace found somewhere in client code
    ;
    ## end of assignment

### _decode_while code : $report_code
    return $report_code;
};
######## /_decode_while ########

######## INTERNAL ROUTINE ########
#
#   _desc_time();       # short
#
# Purpose  : ____
# Parms    : ____
# Reads    : ____
# Returns  : ____
# Writes   : ____
# Throws   : ____
# See also : ____
#
# 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;
};
######## /_desc_time ########

######## INTERNAL ROUTINE ########
#
#   _moving_average();      # short
#
# Purpose  : ____
# Parms    : ____
# Reads    : ____
# Returns  : ____
# Writes   : ____
# Throws   : ____
# See also : ____
#
# Update the moving average of a series given the newest measurement...
#
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;
};
######## /_moving_average ########

######## INTERNAL ROUTINE ########
#
#   _prog_pat();        # short
#
# Purpose  : ____
# Parms    : ____
# Reads    : ____
# Returns  : ____
# Writes   : ____
# Throws   : ____
# See also : ____
#
# 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;
};
######## /_prog_pat ########

######## EXTERNAL ROUTINE ########
#
#   for_progress();     # short
#
# Purpose  : ____
# Parms    : ____
# Reads    : ____
# Returns  : ____
# Writes   : $_[2] ($not_first__$ID in caller's code
# Throws   : ____
# See also : _decode_for
#
# Animate the progress bar of a for loop...
#
sub for_progress {
### ...In for_progress...

    my $caller_id       = $_[0];    # per-use id of this caller
    my $mesg            = $_[1];    #
    my $not_first       = $_[2];    # will be altered so don't shift it off
    my $data            = $_[3];    #

    my $at              ;           #
    my $max             ;           #
    my $elapsed         ;           #
    my $remaining       ;           #
    my $fraction        ;           #

    # Update progress bar...
    if ($not_first) {
    ### for_progress- 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 {
    ### for_progress- else first
        # 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.
        $_[2] = 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_for( $caller_id,
            qq{\r},
             q{ } x $maxwidth,
            qq{\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_for( $caller_id,
                q{  (},
                _desc_time($remaining),
                q{ remaining)},
            );
            $showing{$data} = 1;
        }

        # Close off the line, if we're finished...
        Print_for( $caller_id,
            qq{\r},
             q{ } x $maxwidth,
            qq{\n},
            ) if $at >= $max;
    }
};
######## /for_progress ########

######## EXTERNAL ROUTINE ########
#
#   while_progress();       # short
#
# Purpose  : ____
# Parms    : ____
# Reads    : ____
# Returns  : ____
# Writes   : ____
# Throws   : ____
# See also : ____
#
# Animate the progress bar of a while loop...
#
sub while_progress {
    my $caller_id       = shift;    # per-use id of this caller
    my $mesg            = shift;    #
    my $not_first_ref   = shift;    #

    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))+0.000000000001);

        # 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_for( $caller_id,
            qq{\r},
             q{ } x $maxwidth,
            qq{\r},
            $left,
            sprintf("%-${fillwidth}s",
                   substr($fill x $fillwidth, 0, $length)
                 . $leader),
            $right,
        );
    }
};
######## /while_progress ########

######## EXTERNAL ROUTINE ########
#
#   Print_for( $caller_id, @args );     # short
#
# Purpose   : Print @args to caller's chosen $outfh
# Parms     : $caller_id    : identify which caller
#           : $frame        : we may be called directly or by proxy
#           : @args         : any printable list
# Reads     : %state_of
# Returns   : 1
# Writes    : to $outfh
# Throws    : dies if print fails
# See also  : _get_new_caller_id(), Warn_for(), _decode_assert(), Dump()
#
# Call this only from within replacement code.
# If called by another our-module routine, it will get the wrong stack frame.
#
sub Print_for {
    my $caller_id       = shift;
    my $outfh           = _get_outfh($caller_id);   # get from %state_of

    print {$outfh} @_
        or die   q{Devel::Comments: }  # print failure
            ,    q{Filesystem IO error: }
            ,   qq{Failed to print to output filehandle for $caller_id }
            ,    $!
            ;

    return 1;
};
######## /Print_for ########

######## EXTERNAL ROUTINE ########
#
#   Warn_for( $caller_id, $frame, @args );      # short
#
# Purpose   : Print @args *and* $file, $line to caller's chosen $outfh
#           :    as if it were warn().
# Parms     : $caller_id    : identify which caller
#           : $frame        : we may be called directly or by proxy
#           : @args         : any printable list
# Reads     : %state_of
# Returns   : 1
# Writes    : to $outfh
# Throws    : dies if print fails
# See also  : _get_new_caller_id(), Print_for(), _decode_assert()
#
# This can be called from within replacement code or from S::C;
#   but either way, $frame must be passed in.
sub Warn_for {
    my $caller_id       = shift;
    my $frame           = shift;

    ### In Warn_for():
    ### $caller_id
    ### $frame

    my @caller          = caller($frame);
    ### @caller

#   my $caller_name     = $caller[0];
    my $caller_file     = $caller[1];
    my $caller_line     = $caller[2];

    Print_for( $caller_id, @_, " at $caller_file line $caller_line.\n" );
    return 1;
};
######## /Warn_for ########

######## INTERNAL ROUTINE ########
#
#   _put_state( $caller_id, @caller );      # short
#
# Purpose   : Store current state info
# Parms     : $caller_id    : to put %state_of previous state
#           : @caller       : current state (maybe)
# Reads     : %state_of
# Returns   : 1
# Writes    : %state_of
# Throws    : dies if called with unknown caller
# See also  : _spacer_required(), Dump_for()
#
# This stores not $outfh itself
#   but the initial state of output to it, sort of.
#
sub _put_state {
    my $caller_id       = shift;
    my @caller          = @_;
    my $caller_name     = $caller[0];
    my $caller_file     = $caller[1];
    my $caller_line     = $caller[2];

    die "Devel::Comments: Fatal Error (_put_state): ",
        "No state_of $caller_id.",
        $!      if ( !defined $state_of{$caller_id} );

    my $outfh           = _get_outfh($caller_id);

    $state_of{$caller_id}{-tell}{-outfh}    = tell $outfh;
    $state_of{$caller_id}{-tell}{-stdout}   = tell (*STDOUT);
    $state_of{$caller_id}{-caller}{-file}   = $caller_file;
    $state_of{$caller_id}{-caller}{-line}   = $caller_line;

    return 1;

};
######## /_put_state ########

######## INTERNAL ROUTINE ########
#
#   $flag       = _spacer_required( $caller_id, @caller );  # newline before?
#
# Purpose   : Ensure the smart output starts flush left.
# Parms     : $caller_id    : key %state_of for previous state
#           : @caller       : current state (maybe)
# Reads     : %state_of
# Returns   : Boolean: TRUE to prepend a newline to output
# Writes    : ____
# Throws    : ____
# See also  : Dump_for(), %state_of
#
# Vanilla S::C compared both previous tell()-s of STDOUT and STDERR
#   before deciding to print a prophylactic newline, even though Vanilla
#   only ever printed to STDERR. One might assume Conway does this
#   on *his* assumption that both are connected to the same output device,
#   namely a terminal window or console.
# This may or may not be wise but we preserve the exact Vanilla behavior;
#   while output to disk files contains fewer newlines.
# Since we make no explicit check of which or what kind of filehandle,
#   I cannot explain why this is so.
# The missing newlines are not going to STDOUT, STDERR, or the screen anyway.
#
# TODO: Vanilla outputs a gratuitous newline
#   if $caller_line has changed by more than one line.
#   This may result in rather "loose" output.
#   TODO: Accept a "tighten" arg in use line.
#
sub _spacer_required {
    my $caller_id       = shift;
    my @caller          = @_;
    my $caller_name     = $caller[0];
    my $caller_file     = $caller[1];
    my $caller_line     = $caller[2];

    my $outfh       = _get_outfh($caller_id);   # retrieve from %state_of

#say '$outfh: ', $outfh;
    my $prev_tell_outfh     = $state_of{$caller_id}{-tell}{-outfh};
    my $prev_tell_stdout    = $state_of{$caller_id}{-tell}{-stdout};
    my $prev_caller_file    = $state_of{$caller_id}{-caller}{-file};
    my $prev_caller_line    = $state_of{$caller_id}{-caller}{-line};

    my $flag            ;

# This test is *not* needed, oddly enough!
# Intent was to preserve Vanilla behavior by requiring newline
#   if tell STDOUT had changed when printing to STDERR.
# But with this paragraph disabled, Vanilla is preserved
#   and also 'use Devel::Comments *STDOUT' yields the same output.
# Yet when given a hard disk $fh, fewer gratuitous newlines are output,
#   which is desired.
# I cannot figure out why. Let us consider this a blessing.
#
#   # You might not think you can compare filehandles, but you can...
#   # ... but only if they're identical, not if they're equivalent...
#   # ... *STDERR ne \*STDERR   # although most io routines will accept either
#   if    ( $outfh eq *STDERR ) {   # STDERR chosen, vanilla behavior
#       # newline if STDOUT has been printed to since last smart output
#       $flag   ||= $prev_tell_stdout   != tell(*STDOUT);
#say 'I Vanillaed.';
#   };

    # newline if $outfh has been printed to
    $flag       ||= $prev_tell_outfh    != tell $outfh;

    # newline if $caller_file has changed (???)
    $flag       ||= $prev_caller_file   ne $caller_file;

    # TODO: if $tighten do not...
    # newline if $caller_line has changed by more or less than 1
    $flag       ||= $prev_caller_line   != $caller_line -1;

#~    say 'Doing the newline.' if $flag;                                    #~
#~    return 0;           # never do the newline                            #~
    return $flag;
};
######## /_spacer_required ########

######## EXTERNAL ROUTINE ########
#
#   Dump_for();     # short
#
# Purpose  : Dump a variable (any variable?)
# Parms    : flat list (assigned to hash)
# Reads    : ____
# Returns  : ____
# Writes   : ____
# Throws   : ____
# See also : Data::Dumper, FILTER # Any other smart comment is a simple dump
#
# Dump a variable and then reformat the resulting string more prettily...
#
sub Dump_for {

    my %hash        = @_;
    my $caller_id       = $hash{-caller_id}
        or die   q{Devel::Comments: }  # called with no -caller_id
            ,    q{Replacement code error: }
            ,    q{-caller_id not passed in call to Dump(). }
            ,    $!
            ;

    my $prefix          = $hash{-prefix};
#~ my $exists_varref   = exists $hash{-varref};    # save test              #~
    my $defined_varref  = defined $hash{-varref};   # save test
    my $varref          = $hash{-varref};
    my $no_newline      = $hash{-no_newline};

    my @caller          = caller;       # called by replacement code
#   my $caller_name     = $caller[0];
    my $caller_file     = $caller[1];
    my $caller_line     = $caller[2];
    my $outfh           = _get_outfh($caller_id);   # retrieve from %state_of

    my $spacer_required ;               # TRUE to prepend a newline to output

#~ say $outfh '... Entering Dump_for() ...';                                #~
#~ ### ... Entering Dump_for()                                              #~
#~ ### %state_of                                                            #~

    # Handle timestamps...
    $prefix =~ s/<(?:now|time|when)>/scalar localtime()/ge;
    $prefix =~ s/<(?:here|place|where)>/"$caller_file", line $caller_line/g;

    # Add a newline?
    if ($no_newline) {
        $spacer_required    = 0;
    }
    else {
        $spacer_required    = _spacer_required( $caller_id, @caller );
    };
#~ ### $spacer_required                                                     #~

#~ print $outfh 'defined_varref: ', $defined_varref, '    ';                #~
    # Handle a prefix with no actual variable...
    if ($prefix && !$defined_varref) {
        $prefix =~ s/:$//;
        Print_for( $caller_id, "\n" ) if $spacer_required;
        Print_for( $caller_id, "### $prefix\n" );
        _put_state( $caller_id, @caller );
        return 1;                   # ...abort if not defined $varref
    }

    # or continue...

    # 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...

#~ say $outfh q{};                                                          #~
#~ say $outfh q{-----};                                                     #~
#~ my $gotstuff = join '', @{$varref};                                      #~
#~ say $outfh '@{varref}: >' . $gotstuff . '<';                             #~
#~ say $outfh 'dumped before: >' . $dumped . '<';                           #~
#~ say $outfh 'exists: (', $exists_varref, ')';                             #~

    # report 'null' for "return;" -- see RT#69712
    $dumped =~ s/\$VAR1 = \[];\n/\$VAR1 = \[\n          null\n];\n/;

    $dumped =~ s/\$VAR1 = \[\n//;
    $dumped =~ s/\s*\];\s*$//;
#~ my $len_1;                                                               #~
#~ $len_1 = length $1;                                                      #~
#~ say $outfh '$1: ', $1, 'length: ', $len_1;                               #~
    $dumped =~ s/\A(\s*)//;
#~ $len_1 = length $1;                                                      #~
#~ say $outfh '$1: ', $1, 'length: ', $len_1;                               #~
#~
#~ say $outfh 'dumped after: >' . $dumped . '<';                            #~

    # How much to shave off and put back on each line...
    my $indent  = length $1;
    my $outdent = q{ } x (length($prefix) + 1);
#~ say $outfh 'indent: ', $indent, ' outdent: >', $outdent, '<';            #~
    # 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;
#~ say $outfh 'dumped later: >' . $dumped . '<';                            #~

    # Print the message...
    Print_for( $caller_id, "\n" ) if $spacer_required;
    Print_for( $caller_id, "### $prefix $dumped\n" );
    _put_state( $caller_id, @caller );

    return 1;
};
######## /Dump_for ########

#~ say '---| Devel::Comments at line ', __LINE__;                           #~

#############################
######## END MODULE #########
1;
__END__