############################################################################### # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 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 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # ########################################################################### # # # 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: # # # ########################################################################### # # # ############################################################################### ############################### # ######################## ###### 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;