###############################################################################
# #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # 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.9.0-PRE # #
# # Date :
# # 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( ERR
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[ (%E)]',
};
my @LVL = ( # now with less evil, I swear
'^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(
LVL
MSG
FNC
EXT
);
#######################################
# ################################
###### START OF THE OBJECT INTERFACE
sub new {
my ($class,$stp) = @_;
unless (defined $stp) { #simple mode
$stp = {};
}
unless (ref $stp eq 'HASH') {
carp 'DATA::LOGGER WAS NOT INIT PROPERLY';
return;
}
my $log = {};
$stp->{Title} = _stp_title ($stp,caller);
$log->{Title} = $stp->{Title};
$log->{Level} = _stp_level ($stp);
$log->{String} = _stp_string ($stp);
$log->{Token} = _stp_tokens ($stp);
$log->{Explicit} = _stp_mode ($stp);
$log->{Path} = _stp_path ($stp);
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 ERR 'EXPLICIT' if _stp_mode($stp);
return DEFAULT_LEVEL;
}
#####
#
# get the calling script's title
#
sub _stp_title {
my ($stp,@caller) = @_;
unless (defined $stp->{Title}) {
return basename($caller[1]);
} else {
return $stp->{Title};
}
}
#####
#
# duh
#
sub _stp_string {
my ($stp) = @_;
return _charachangi($stp->{String}) if defined $stp->{String};
return ERR 'EXPLICIT' if _stp_mode($stp);
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 'EXPLICIT' if _stp_mode($stp);
$stp->{Path} =
mkdir($stp->{Path},0777) or return ERR 'MKDIR (BASE)';
}
if (defined $stp->{Dated}) {
$stp->{Path} = skew $stp->{Path}, '%Y-%M-%D';
mkdir($stp->{Path},0777) or return ERR 'MKDIR (DATED)';
}
return ERR 'PATH NOT DIR' unless -d $stp->{Path};
return $stp->{Path};
}
#####
#
# 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 'HOUSEKEEPING' unless housekeep(
$dir,
int($stp->{Keep}), # I don't even trust my mom.
1
);
}
return;
}
#####
#
# on it's own because it both
# annoys and desmozes me....
# desmozes?
#
sub _stp_tokens {
return {
A => '',
T => '',
L => '',
F => undef, #off by default
Y => _date_object('year'),
M => _date_object('month'),
LETS_GET_DRUGS => 'zeke',
D => _date_object('day'),
h => _date_object('hour'),
m => _date_object('minute'),
s => _date_object('second'),
};
}
############################
# #####################
###### DECODING 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|other text]
# style "or" block, if %b does not prove to
# be active and set, use text on the otherside
# of the | character
#
sub _deblock {
my ($toke,$str) = @_;
while ($str =~ s/\[([^\[\]]*)\]/\%0/o) {
my $blk = $1;
if ($blk =~ /\%([^\d])/o) {
my $wtf = _have_a_toke_man($toke,$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 ($toke,$str) = @_;
$str =~ s/\%(.)/_have_a_toke_man($toke,$1)/ge;
return $str;
}
sub _have_a_toke_man {
#reeecooooooooooooooooooode
}
##############################
# #######################
###### USER TOKEN FUNCTIONS
#####
#
# the decoder for tokens!
# fun for the whole family
# (seats six)
#
sub decode {
my ($log,$str) = @_;
$str = _deblock($log,$str);
$str = _detoke($log,$str);
return $str;
}
#################################
# ##########################
###### STUFF THAT BUILDS STUFF
#####
#
# builds a date closure
# @<%>{<@>} = (<@>); # ftw
#
sub _date_object {
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)};
}
}
###########################
# ####################
###### LOGGING FUNCTIONS
sub print {
# reeeeeeeeeeeeecode!
}
######################################
# ###############################
###### OBJECT FUNCTIONS AND ALIASES
#####
#
# these are the main aliases
#
sub LOGERROR { 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 LOGDEBUG { shift->print(); } #
sub LOGCLOSE { return 1; } #
sub LOGOPEN { return 1; } #
sub LOGARRAY { return 1; } # hmmm...
sub LOGHASH { return 1; } #
sub LOGDUMP { return 1; } #
#####
#
# 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 (@_); } # hope yer
sub RAW { shift->print (@_); } # know doing
sub PRINT { shift->print (@_); } # you what
sub say { shift->LOGNOTE (@_); }
sub SAY { shift->LOGNOTE (@_); }
sub DUMP { shift->LOGDUMP (@_); }
sub dump { shift->LOGDUMP (@_); }
sub array { shift->LOGARRAY (@_); }
sub hash { shift->LOGHASH (@_); }
sub log { shift->LOGNOTE (@_); }
sub die { shift->LOGDIE (@_); }
sub error { shift->LOGERROR (@_); }
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 (@_); }
#################################
# ###############
###### ONE!!!1
1;