###############################################################################
# #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # Title : Data::Logger.pm # #
# # Description : A super simple logger, you don't actually need to tell i # #
# # a single thing. # #
# # Coded by : Justin "I'm Really Tired Now" Lee # #
# # Version : 0.8.0-PRE # #
# # Date : Thursday, March 20, 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 %TOK = ( # global tokens
1 => '\\',
2 => '%',
3 => '[',
4 => ']',
5 => '|',
);
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
#####
# determines whether to run in
# explicit mode (meaning the user
# must specify all their info) or
# simple mode (meaning if a piece
# of information is left out, a
# default is used
sub _stp_mode {
my ($stp) = @_;
if (exists $stp->{Explicit} and $stp->{Explicit}) {
return 1;
} else {
return 0;
}
}
#####
# sets the logging level to
# use, can be overriden by the
# user at log time
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;
}
#####
# duh
sub _stp_string {
my ($stp) = @_;
return _charachangi($stp->{String}) if defined $stp->{String};
return { ERR => 'EXP' } if _stp_mode($stp); #explicit
return DEFAULT_STRING;
}
#####
# finds the correct path to use,
# if 'Dated' is set, then it will
# use (or create) directories with
# the current date (yyyy-mm-dd) and
# store the log files there
# if any step fails the logger dies
# (even with out explicit) cause you
# know, it would just be retarded to
# continue... with the exception of
# 'Path', we can guess that if we have to
sub _stp_path {
my ($stp,$tok) = @_;
if (not defined $stp->{Path}) {
return { ERR => 'EXP' } if _stp_mode($stp); #explicit
$stp->{Path} = DEFAULT_dir;
mkdir($stp->{Path},0777) or return { ERR => 'FAILURE: MKDIR' };
}
if (defined $stp->{Dated}) {
$stp->{Path} = skew $stp->{Path}, decode('%Y-%M-%D',$tok);
mkdir($stp->{Path},0777) or return { ERR => 'FAILURE: MKDIR' };
}
return $stp->{Path} if -d $stp->{Path};
return { ERR => 'ERROR: PATH NOT DIR' };
}
#####
# use housekeep to remove all
# but the last 'Keep' logs,
# if you catch my meaning
sub _stp_clean_house {
my ($stp,$dir) = @_;
if (defined $stp->{Keep}) {
return { ERR => 'FAILURE: HOUSEKEEPING' } unless housekeep(
$dir,
int($stp->{Keep}), # I don't even trust my mom.
1
);
}
return 1;
}
#####
# on it's own because it both
# annoys and desmozes me....
# desmozes?
sub _stp_tokes {
return (
A => undef,
F => [0,undef],
T => undef,
L => undef,
Y => _mk_dt_obj_thg('year'),
M => _mk_dt_obj_thg('month'),
LETS_GET_DRUGS => 'zeke',
D => _mk_dt_obj_thg('day'),
h => _mk_dt_obj_thg('hour'),
m => _mk_dt_obj_thg('minute'),
s => _mk_dt_obj_thg('second'),
);
}
#####
# build the token hash
sub _stp_tokens {
my ($stp,$caller) = @_;
my $tok = _have_a_toke_man();
if (defined $stp->{Functional}) {
$tok->{F}->{toe} = 1;
}
if (defined $stp->{Title}) {
$tok->{T}->{val} = $stp->{Title};
} else {
$tok->{T}->{val} = $caller;
}
return $tok;
}
#####
# test the setup for ERRROORRRZZZZzz
# if there's an error return it, else
# return the log
sub _stp_can_has_errors {
return 0; # to be done
}
#####
# sadly the cake was a lie :(
sub _setup {
my ($stp,$caller) = @_;
unless (defined $stp) { $stp = {}; }
unless (ref $stp eq 'HASH') { return ( ERR => 1 ); }
my %log;
$log->{Handle} = new FileHandle;
$log->{Level} = _stp_level($stp);
$log->{String} = _stp_string($stp);
$log->{Token} = _stp_tokens($stp,$caller);
$log->{Path} = _stp_path($stp,$log->{Token});
$log->{Explicit} = _stp_mode($stp);
$log->{Handle}->open($log->{Path},'>');
return _stp_can_has_errors(%log);
}
###############################
## ########################
###### TOKEN FUNCTIONS
#####
# removes all escaped characters
# so that they aren't picked up
# by the _deblock()er
sub _charachangi {
my ($str) = @_;
$str =~ s/\\\\/\%1/og;
$str =~ s/\\\%/\%2/og;
$str =~ s/\\\[/\%3/og;
$str =~ s/\\\]/\%4/og;
$str =~ s/|/\%5/og;
return $str;
}
#####
# recursively tests "if" blocks
# which means: if the first token
# in the block is active and set
# the whole block will be left for
# parsing
# if a string was [ %a: [ %b ] ] and
# %a was not active & set, nothing
# would be shown; even if the %b block
# was active & set
# future: implement a [%b|\%b was invalid]
# style "or" block, if %b does not prove to
# be active and set, use text on the otherside
# of the | character
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;
}
#####
# after all blocks are evaluated
# _detoke will interpolate all tokens
# with their values (with help from
# _have_a_toke_man)
sub _detoke {
my ($str) = @_;
$str =~ s/\%(.)/_have_a_toke_man($1)/ge;
return $str;
}
sub _decode {
my ($log,$str) = @_;
$str = _deblock($log,$str);
$str = _detoke($log,$str);
return $str;
}
sub _have_a_toke_man {
my ($log,$tok) = @_;
# used to be _gettoke() but I liked
# this name better... also needs to
# be recoded, I have plans!
}
#################################
## ##########################
###### STUFF THAT BUILDS STUFF
#####
# builds a date closure
# @{qw()} = (); # ftw
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 {
}
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
#####
# these are the main aliases
sub LOGDEBUG { shift->print (); } #
sub LOGDIE { shift->print (); } # to be done, need to decide how I want
sub LOGWARN { shift->print (); } # shift->print(); to recieve it's args,
sub LOGNOTE { shift->print (); } # maybe as a hash? or keep as an array?
sub LOGPRINT { shift->print (); } #
#####
# that's all the main ones, these
# are just some handy-dandy aliases
# and you can like, add some too
# .... if you wanted to... just...
# putting that out there... ...
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 (); }
#####################
## ##############
###### ONE!!!1 ...
1;