################################################################################
# #
# ############################################################################ #
# # 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.6.0-PRE # #
# # Date : Tuesday, March 4, 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/> # #
# ############################################################################ #
# #
################################################################################
package Data::Logger;
use strict;
use warnings;
our(@ISA,@EXPORT_OK);
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw( _skew );
}
use Carp;
use FileHandle;
use File::Basename;
use File::Find;
use Class::Date qw(now);
#####################
# ##############
### "CONSTANTS"
my @LEVELS = (
'fatal|warn(?:ing)|d(?:ie|eath)',
'info(?:rmation)|log|note',
'debug'
);
#######################################
# ################################
### START OF THE OBJECT INTERFACE
sub new {
my $class = shift;
my $log = { _setup(@_) };
return if exists $log->{ERR};
return bless $log, $class;
}
#############################
# ######################
### THE _SETUP FUNCTION
sub _setup {
my $stp = shift;
my %log = (
stamp => '[%h:%m:%s] (%L)'."\t".'- {[%F]}{ %A}{ [ERROR] %E}',
token => { _have_a_toke_man() },
conf => {
level => 2,
autor => 0,
lpath => _skew(@{[ fileparse($main::0) ]}[1],'logs')
}
);
unless (defined $stp)
{ $stp = {}; }
unless (ref $stp eq 'HASH')
{ return ( ERR => 1 ); }
if (defined $stp->{Level})
{ $log{level} = int($stp->{Level}); } # I don't even trust my mom
if (defined $stp->{String})
{ $log{stamp} = $stp->{String}; }
if (defined $stp->{Sectional})
{ $log{token}->{S}->{toe} = 1; }
if (defined $stp->{Directory})
{ $log{lpath} = _skew($stp->{Directory}); }
if (defined $stp->{To_Keep})
{ unless (_housekeep($log{lpath},int($stp->{To_Keep}))) { return ( ERR => 1 ); } }
unless (-d $log{lpath})
{ unless (mkdir($log{lpath},0777)) { return ( ERR => 1 ); } }
if (defined $stp->{Dated_Directories})
{
unless (defined $stp->{File_Name})
{ $stp->{File_Name} = '%h;%m;%s.log'; }
$log{lpath} = _skew($log{lpath},_decode('%Y-%M-%D'));
unless (mkdir($log{lpath},0777))
{ return ( ERR => 1 ); }
}
$stp->{File_Name} = _decode(defined $stp->{File_Name} ?
$stp->{File_Name} :
'%Y-%M-%D %h;%m;%s.log');
$log{lpath} = _skew($log{lpath},$stp->{File_Name});
$log{handle} = new FileHandle;
$log{handle}->open($log{lpath},'>');
unless (defined $log{handle})
{ return ( ERR => 1 ); }
return %log;
}
##################################
# ###########################
### RANDOM AWESOME FUNCTIONS
sub _skew { #murder stupid paths
my $skew = join('/',@_);
$skew =~ s/(?:\\|\/)+/\//go;
return $skew;
}
#########################
# ##################
### TOKEN FUNCTIONS
############
# internal #
############
sub _decode {
my $str = shift;
$str =~ s/(?<!\\)\{(.*?)(?<!\\)\}/_deblock($1)/ge; #wrapper
$str =~ s/(?<!\\)\%(.)/_detoke($1)/ge;
$str =~ s/(?<!\\)\\(.)/$1/g;
return $str;
}
sub _deblock {
my $blk = shift;
if ($blk =~ /(?<!\\)\%(.)/o) {
my $we_got_drugs = _detoke($1);
if ($we_got_drugs and $we_got_drugs ne '?') {
return $blk;
}
}
return '';
}
sub _detoke {
my $tik = shift;
my $tak = shift;
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 _update_tokens {
my $tik = shift;
my $tok = shift;
}
sub _mk_dt_obj_thg {
my $gm = shift or return;
return sub {
my %dt;
@dt{
qw( year
month
day
hour
minute
second )
} = split(/(?:\s|:|-|;)+/,now);
return scalar $dt{lc($gm)};
}
}
sub _have_a_toke_man {
return (
A => { # message
val => '',
toe => 1
},
F => { # function title
val => '',
toe => 0
},
S => { # script name
val => basename($main::0), #'super cool script.pl', #'fake name',
toe => 1
},
L => { # log level
val => '',
toe => 1
},
E => { # error message
val => '',
toe => 0
},
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
}
);
}
############
# external #
############
sub last {
my $log = shift;
my %LST = (
'ERR' => _get_tok('E'),
'MSG' => _get_tok('A'),
'LVL' => _get_tok('L')
);
# will use closure to provide the user
# with a hash ref, think: $last_log = $log->last;
# print $last_log->{'ERR'};
# but this may not be needed as they gave -us- that error >.>
# whatever
}
sub reset {
## will reset all pertinent tokens
}
################################
# #########################
### CORE LOGGING FUNCTIONS
sub print {
my $log = shift;
$log->reset;
$log->{token} = _update_tokens(shift);
}
##########################
# ###################
### OBJECT FUNCTIONS
sub LOGCLOSE {
my $log = shift;
$log->print({
MSG => shift,
LVL => 'INFO',
EXT => shift
});
$log->{handle}->close;
}
sub LOGNOTE {
my $log = shift;
$log->print({
MSG => shift,
LVL => 'INFO',
EXT => shift
});
}
sub LOGDEBUG {
my $log = shift;
$log->print({
MSG => shift,
LVL => 'DEBUG',
EXT => shift
});
}
sub LOGWARN {
my $log = shift;
$log->print({
MSG => shift,
LVL => 'WARN',
EXT => shift
});
carp $log->last->('ERR');
}
sub LOGDIE {
my $log = shift;
$log->print({
MSG => shift,
LVL => 'FATAL',
EXT => shift
});
$log->{handle}->close;
croak $log->last->('ERR');
}
#################################
# ##########################
### OBJECT FUNCTION ALIASES
sub LOGPRINT { shift->print (@_); }
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!!
#####################
# ##############
### ONE!!!1 ...
1;