perl/lib/Thrasher/Log.pm

   1 package Thrasher::Log;
   2 use strict;
   3 use warnings;
   4
   5 use Encode qw(encode);
   6 use POSIX qw(strftime);
   7
   8 =pod
   9
  10 =head1 NAME
  11
  12 Thrasher::Log - contains logging functions that control log output
  13
  14 =head1 SYNOPSIS
  15
  16  use Thrasher::Log qw(log);
  17  log("Error in sample code for POD documentation for Thrasher::Log.");
  18
  19 =head1 DESCRIPTION
  20
  21 Obviously, this is the logging function.
  22
  23 This was pulled out into a separate function due to load order issues;
  24 it turns out this really needs to be in a separate module.
  25
  26 =cut
  27
  28 use base 'Exporter';
  29
  30 # Ugly, but we need to consolidate the two debugging modules...
  31 our @EXPORT_OK = qw(log logger debug dies);
  32 our %EXPORT_TAGS = (all => \@EXPORT_OK);
  33
  34 our $DEBUG = 0;
  35 our $SILENT = 0; # Really only useful for testing this module
  36 our $logger_sub;
  37
  38 binmode STDERR, ':utf8';
  39
  40 sub log ($;$) {
  41     my $msg = shift;
  42     my $depth = shift;
  43
  44     my ($package, $filename, $line);
  45     if (!$depth) {
  46         ($package, $filename, $line) = caller;
  47     } else {
  48         ($package, $filename, $line) = caller $depth;
  49     }
  50
  51     my $time = strftime("%F %H:%M:%S", localtime());
  52     my $outp = "($time) $package\:$line - $msg\n";
  53
  54     if (defined($logger_sub)) {
  55         $logger_sub->($outp);
  56         return;
  57     }
  58
  59     #my $out_octets = encode("utf-8", $outp);
  60
  61     print STDERR $outp if not $SILENT;
  62     return ($filename, $line, $msg);
  63 }
  64
  65 sub debug ($;$) {
  66     my $s = shift;
  67     my $level = shift || 1;
  68
  69     if ($level > $DEBUG) {
  70         return 0;
  71     }
  72
  73     if ($DEBUG) {
  74         if (ref($s) eq 'CODE') {
  75             local $@;
  76             my $result;
  77             eval {
  78                 $result = $s->();
  79             };
  80             if ($@) {
  81                 return Thrasher::Log::log("While trying to print debug message "
  82                             ."based on a code ref, got an error: $@", 1);
  83             } else {
  84                 return Thrasher::Log::log($result, 1);
  85             }
  86         } else {
  87             return Thrasher::Log::log($s, 1);
  88         }
  89     }
  90
  91     return 0;
  92 }
  93
  94 # logger is a wrapper for calls to old Debug module.  We should
  95 # antiquate "log" in favor of something else.  Perhaps this?
  96 #
  97 sub logger {
  98     my $s = shift;
  99
 100     return Thrasher::Log::log($s, 1);
 101 }
 102
 103
 104 =item *
 105
 106 C<dies>($subroutine, $check, $name) - Evaluates $subroutine and fails if
 107 $@ is not populated.
 108
 109 If $check is defined, it is tested for truth.  This may also be a reference
 110 to a regex.  In which case the regex is called and tested for truth.
 111
 112 $name simply defines what is initially displayed on pass or fail.
 113
 114 =cut
 115
 116 sub dies (&;$$) {
 117     eval 'use Test::More;';
 118     my $code = shift;
 119     my $check = '';
 120     if (@_ == 2) {
 121         $check = shift;
 122     }
 123     my $name = shift;
 124
 125     {
 126         local $@ = '';
 127         eval { $code->(); };
 128
 129         if (!$@) {
 130             fail($name);
 131             return;
 132         }
 133
 134         my $die_message = $@ . '';
 135         if ($check) {
 136             if (ref($check) eq 'Regexp') {
 137                 if ($die_message !~ /$check/) {
 138                     fail($name . " (regex $check not in '$die_message')");
 139                 }
 140             } else {
 141                 if (index($die_message, $check) == -1) {
 142                     fail($name . " (string $check not in $die_message)");
 143                 }
 144             }
 145         }
 146     }
 147
 148     pass($name);
 149 }
 150 1;