view release on metacpan or  search on metacpan

lib/Fred/Fish/DBUG/ON.pm  view on Meta::CPAN

B<fish> logs for each filter I<level>.  Each I<level> may use different
I<colors> or repeat the same I<color> between I<levels>.

See I<DBUG_FILTER()> above to see what the valid levels are.

See L<Term::ANSIColor> for what I<color> strings are available.  But I<undef>
or the empty string means to use no I<color> information.  (default)  You may
use strings like ("red on_yellow") or ("red", "on_yellow") or even use the color
constants (RED, ON_YELLOW).

If L<Term::ANSIColor> is not installed, this method does nothing.  If you set
I<$ENV{ANSI_COLORS_DISABLED}> to a non-zero value it will disable your I<color>
choice as well.

Returns B<1> if the color request was accepted, else B<0>.

=cut

# ==============================================================
sub DBUG_SET_FILTER_COLOR
{
   my $level      = shift;   # Always non-zero ...
   my @color_attr = @_;      # List of color attributs.

   # If color not supported ...
   return (0)   if ( $color_supported == 0 );

   my $valid_level = 0;
   if ( $level && $level =~ m/^\d+$/ ) {
      if ( (DBUG_FILTER_LEVEL_MIN <= $level && $level <= DBUG_FILTER_LEVEL_MAX) ||
           ($level == DBUG_FILTER_LEVEL_INTERNAL) ) {
         $valid_level = 1;
      }
   }

   # Merge all the color attributes into a single escape sequence string ...
   my $color_str = "";
   if ( $valid_level ) {
      local $ENV{ANSI_COLORS_DISABLED} = 0;       # Enable colors!
      local $SIG{__DIE__} = "";                   # Disable any die customization ...

      foreach my $cm ( @color_attr ) {
         next  unless (defined $cm);
         next  if ( $cm =~m/^\s*$/ );
         eval {
            # Throws an exception if not a valid color string such as "red",
            # "red on_yellow", or "bold red on_yellow".
            my $str = color ($cm);     # Convert to an escape sequence ...
            $color_str .= $str;
            # print STDERR "Valid Color String '$cm'\n";
         };
         if ( $@ ) {
            eval {
               # Throws exception if color value wasn't from a color macro!
               # Ex: use Term::ANSIColor qw(:constants); $color = RED;
               # Not all color macro values are escape sequences ...
               my @str = Term::ANSIColor::uncolor ($cm);
               foreach my $s ( @str ) {
                  $color_str .= color ($s);     # Makes sure always an escape sequence ...
               }
               # print STDERR "Valid Color Macro(s): '", join (", ", @str), "'\n";
            };
            if ( $@ ) {
               warn ("Invalid color string '$cm'.\nColor request reset to no colors for level $dbug_levels[$level]!\n");
               $color_str = "";
               last;
            }
         }
      }
   }

   # Save the results ...
   if ( $valid_level ) {
      if ( $color_str ) {
         local $ENV{ANSI_COLORS_DISABLED} = 0;       # Enable colors!
         $color_list[$level] = $color_str;           # Get the escape sequence for this color.
         $color_clear = color ("clear");             # Back to defaults.
      } else {
         delete ( $color_list[$level] );
      }
   }

   return ( $valid_level );
}


# ==============================================================
# Get the colors to use for the current filter level.
sub _get_filter_color
{
   my $level = shift;

   return ("", "")  if ( $color_supported == 0 );
   return ("", "")  if ( $ENV{ANSI_COLORS_DISABLED} );
   return ("", "")  unless ( defined $color_list[$level] );

   return ( $color_list[$level], $color_clear );
}


=item DBUG_ACTIVE ( )

This function tells you if B<fish> is currently turned on or not.

It will return B<0> if I<DBUG_PUSH()> was never called, called with
S<B<off =E<gt> 1>>, or if I<DBUG_PAUSE()> is currently in effect.  It ignores
any filter request.

It will return B<1> if B<fish> is currently writing to a file.

It will return B<-1> if B<fish> is currently writing to your screen via
B<STDERR> or B<STDOUT>.

=cut

# ==============================================================
sub DBUG_ACTIVE
{
   my $active = 0;   # Assume not currently active ...

   if ( $dbug_global_vars{on} && (! $dbug_global_vars{pause}) &&