Miscellany

################################################################################
#                                                                              #
#   ########################################################################   #
# # Title       : Data::Logger.pm                                            # #
# # Description : A super simple logger, you don't actually need to tell it  # #
# #               a single thing.                                            # #
# # Coded by    : Justin "I'm Really Tired Now" Lee                          # #
# # Version     : 0.7.0-PRE                                                  # #
# # Date        : Monday, March 10, 2008                                     # #
# # License     : GNU General Public License v.2                             # #
# #               Copyright (C) 2008  Justin Lee  <kool.name at gmail.com>   # #
#   ########################################################################   #
#                                                                              #
#   ########################################################################   #
# # This program is free software; you can redistribute it and/or            # #
# # modify it under the terms of the GNU General Public License version 2    # #
# # as published by the Free Software Foundation.                            # #
# #                                                                          # #
# # This program is distributed in the hope that it will be useful,          # #
# # but WITHOUT ANY WARRANTY; without even the implied warranty of           # #
# # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            # #
# # GNU General Public License for more details.                             # #
# #                                                                          # #
# # You should have received a copy of the GNU General Public License        # #
# # along with this program; if not, write to the Free Software              # #
# # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA            # #
# # 02110-1301, USA.  Or, see: <http://www.gnu.org/licenses/>                # #
#   ########################################################################   #
#                                                                              #
################################################################################



   ###############################
  ## ########################
###### MODULE PREAMBLE

package Data::Logger;

use strict;
use warnings;
use subs qw( skew );

use Carp;
use Deans::Functions qw( skew housekeep );
use FileHandle;
use File::Basename;
use File::Find;
use Class::Date qw(now);



   ##########################################
  ## ###################################
###### `GLOBAL' VARIABLES AND CONSTANTS

use constant {
  DEFAULT_LEVEL => 2,
  DEFAULT_STRING => '\\[%h:%m:%s\\] [(%F)] %L:[ %A]'
};

my @LVL = ( # now with less evil
  '^one|first|(?:warn(?:ing)?|err(?:(?:o|0)r)?|fatal|d(?:ie|eath))(?:s|z)?|1$',
  '^(?:log(?:ging)?|noted?|info(?:rmation))(?:s|z)?|second|two|2$',
  '^third|debug(?:g?(?:er|ing))?(?:s|z)?|all|three|3$'
};

my @ORD = qw(
  MSG
  LVL
  ERR
  FNC
);



   ###############################
  ## ########################
###### START OF THE OBJECT INTERFACE

sub new {
  my ($class,$config) = @_;

  my $log = {
    _setup($config,(caller));
  };

  return if exists $log->{ERR};
  return bless $log, $class;
}



   ###############################
  ## ########################
###### THE _SETUP FUNCTIONZ

sub _stp_mode {
  my ($stp) = @_;
  if (exists $stp->{Explicit} and $stp->{Explicit}) {
    return 1;
  } else {
    return 0;
  }
}

sub _stp_level {
  my ($stp) = @_;
  if (defined $stp->{Level}) {
    for (my $i = 0; $i < $#LVL; $i++) {
      return $i if $stp->{Level} =~ /$LVL[$i]/i;
    }
  }

  return if _stp_mode($stp); #explicit

  return DEFAULT_LEVEL;
}

sub _stp_string {
  my ($stp) = @_;
  return _charachangi($stp->{String}) if defined $stp->{String};

  return if _stp_mode($stp); #explicit

  return DEFAULT_STRING;
}

sub _stp_path {
  my ($stp,$tok) = @_;
  if (not defined $stp->{Path}) {
    return if _stp_mode($stp); #explicit

    $stp->{Path} = DEFAULT_dir;
    mkdir($stp->{Path},0777) or return;
  }
  if (defined $stp->{Dated}) {
    $stp->{Path} = skew $stp->{Path}, decode('%Y-%M-%D',$tok);
    mkdir($stp->{Path},0777) or return;
  }

  return $stp->{Path} if -d $stp->{Path};
  return;
}

sub _stp_clean_house {
  my ($stp,$dir) = @_;
  if (defined $stp->{Keep}) {
    return unless housekeep(
      $dir,
      int($stp->{Keep}), # I don't even trust my mom.
      _stp_mode($stp)
    );
  }

  return 1;
}

sub _stp_tokens {
  my ($stp) = @_;
  my $tok = _have_a_toke_man();

  if (defined $stp->{Functional}) {
    $tok->{F}->{toe} = 1;
  }
  if (defined $stp->{Title}) {
    $tok->{
}

sub _setup {
  my ($stp,@caller) = @_;

  unless (defined $stp) { $stp = {}; }
  unless (ref $stp eq 'HASH') { return _throw_error('STP','Hash'); }

  my %log;
  $log->{Handle}   = new FileHandle;
  $log->{Level}    = _stp_level($stp);
  $log->{String}   = _stp_string($stp);
  $log->{Token}    = _stp_tokens($stp);
  $log->{Path}     = _stp_path($stp,$log->{Token});
  $log->{Explicit} = _stp_mode($stp);

  $log->{Handle}->open($log->{Path},'>');

  defined $_->[0] or _throw_error(@{$_->[1]}) foreach (
    [$log->{Level},    ['STP','Level']],
    [$log->{String},   ['STP','String']],
    [$log->{Path},     ['STP','Path']],
    [$log->{Handle},   ['STP','Handle']],
    [_stp_clean($stp,$log->{Path}),
                       ['STP','Clean']]
  );

  undef $stp;
  return %log;
}



   ###############################
  ## ########################
###### TOKEN FUNCTIONS

sub _deblock {
  my ($str) = @_;
  while ($str =~ s/\[([^\[\]]*)\]/\%0/o) {
    my $blk = $1;
    if ($blk =~ /\%([^\d])/o) {
      my $wtf = _gettoke($1);
      if ($wtf and $wtf ne '?') {
        $str =~ s/\%0/$blk/;
        next;
      }
    } else {
      $str =~ s/\%0//o;
    }
  }

  return $str;
}

sub _detoke {
  my ($str) = @_;
  $str =~ s/\%(.)/_gettoke($1)/ge;
  return $str;
}

sub _gettoke {
  my ($log,$tak) = @_;
  my $tik = $log->{token};
  if (exists $tik->{$tak} and $tik->{$tak}->{toe}) { # exists & active
    if (defined $tik->{$tok}->{val}) { # defined
      if (ref $tik->{$tok}->{val} eq 'CODE') {
        return &{$tik->{$tok}->{val}};
      } else {
        return $tik->{$tok}->{val};
      }
    } else {
      return '?'; # active, but no value (suggests problem)
    }
  } else {
    return ''; # doesn't exist or not active
  }
}

sub _charachangi {
  my ($str) = @_;
  $str =~ s/\\\\/\%1/og;
  $str =~ s/\\\%/\%2/og;
  $str =~ s/\\\[/\%3/og;
  $str =~ s/\\\]/\%4/og;
  return $str;
}



   #################################
  ## ##########################
###### STUFF THAT BUILDS STUFF

sub _mk_hash {
  return $_[0] if ref $_[0] eq 'HASH';
  return {
    MSG => $_[0], 
    LVL => $_[1],
    ERR => $_[2],
    FNC => $_[3]
  };
}

sub _mk_dt_obj_thg {
  my ($gm) = @_;
  return unless defined $gm;
  return sub {
    my %dt;
    @dt{
      qw( year
          month
          day
          hour
          minute
          second )
    } = split(/(?:\s|:|-|;)+/,now);

    return scalar $dt{lc($gm)};
  }
}



   ###############################
  ## ########################
###### CORE LOGGING FUNCTIONS

sub print {
  my ($log,@tik) = @_;
  $log = $log->update($tik);
}

sub decode {
  my ($log,$str) = @_;
  $str = _deblock($log,$str);
  $str = _detoke($log,$str);
  return $str;
}

sub update {
  my ($log,@tik) = @_;
  if (ref $tik[0] eq 'HASH') {
    $log = $log->_update_tokens(map {
      exists $tik[0]->{$_} ? $tik[0]->{$_} : undef
    } @ORD);
  } else {
    $log = $log->_update_tokens(@tik)
  }

  $log or return;
  return $log;
}



   ###############################
  ## ########################
###### OBJECT FUNCTION ALIASES

sub LOGPRINT { shift->print    (@_); }
sub LOGDEBUG { shift->print(_mk_hash('DEBUG',@_)) }
sub LOGDIE   { shift->print(_mk_hash('FATAL',@_)) }
sub LOGWARN  { shift->print(_mk_hash('WARNING',@_)) }
sub LOGNOTE  { shift->print(_mk_hash('INFO',@_)) }
sub raw      { shift->print    (@_); }
sub log      { shift->LOGNOTE  (@_); }
sub die      { shift->LOGDIE   (@_); }
sub warn     { shift->LOGWARN  (@_); }
sub close    { shift->LOGCLOSE (@_); }
sub debug    { shift->LOGDEBUG (@_); }
sub note     { shift->LOGNOTE  (@_); }
sub DEBUG    { shift->LOGDEBUG (@_); }
sub WARN     { shift->LOGWARN  (@_); }
sub DIE      { shift->LOGDIE   (@_); }
sub LOG      { shift->LOGNOTE  (@_); }
sub NOTE     { shift->LOGNOTE  (@_); }
sub PRINT    { shift->print    (@_); }
 # add yer own!!! PARRTYYYYYY!!



   ###############################
  ## ########################
###### REALLY LONG FUNCTIONS

sub _have_a_toke_man {
  return (
    A => { # message
      val => '',
      toe => 1
    },
    F => { # function title
      val => '',
      toe => 0
    },
    T => { # script name
      val => '',
      toe => 1
    },
    L => { # log level
      val => '',
      toe => 1
    },
    Y => {
      val => _mk_dt_obj_thg('year'),
      toe => 1
    },
    M => {
      val => _mk_dt_obj_thg('month'),
      toe => 1
    },
    LETS_GET_DRUGS => {
      val => 'lets get drugs!',
      toe => 0
    },
    D => {
      val => _mk_dt_obj_thg('day'),
      toe => 1
    },
    h => {
      val => _mk_dt_obj_thg('hour'),
      toe => 1
    },
    m => {
      val => _mk_dt_obj_thg('minute'),
      toe => 1
    },
    s => {
      val => _mk_dt_obj_thg('second'),
      toe => 1
    },
  );
}



 #####################
 # ##############
 ### ONE!!!1 ... 

1;