Untitled

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

our(@ISA,@EXPORT_OK);
BEGIN {
  use subs qw(skew); #undouchify constant
  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 AND DEFAULTS

    # Eventually break these off into Data::Logger::Const?

use constant { #caller info
  CALLER_ttl => basename($main::0),
  CALLER_dir => skew(@{[ fileparse($main::0) ]}[1])
};

use constant { #defaults
  DEFAULT_dir => skew(@{[ fileparse($main::0) ]}[1], 'logs'),
  DEFAULT_lvl => 2,
  DEFAULT_str => '\\[%h:%m:%s\\] (%L) -[ %A][ %E]',
};

use constant { #levels
  LEVEL_err => 'one|first|(?:warn(?:ing)?|fatal|d(?:ie|eath))(?:s|z)?|1', #icanhazlogz?
  LEVEL_log => '(?:log(?:ging)?|noted?|info(?:rmation))(?:s|z)?|second|two|2',
  LEVEL_all => 'third|debug(?:g?(?:er|ing))?(?:s|z)?|all|three|3'
};



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

    # Find a way to return _setup()'s ERR messages.

sub new {
  my ($class,$config) = @_;
  my $log = { _setup($config) };
  return if exists $log->{ERR};
  return bless $log, $class;
}



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

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

sub _stp_level {
  my ($stp) = @_;
  if (defined $stp->{Level}) {
    foreach my $gex (LEVEL_err,LEVEL_log,LEVEL_all) {
      return chop($gex) if $level =~ /^$gex$/i; # this is an example of evil magic
    }
  }

  return if _stp_mode($stp); #explicit

  return DEFAULT_lvl;
}

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

  return if _stp_mode($stp); #explicit

  return DEFAULT_str;
}

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; #fail
  }
  if (defined $stp->{Dated}) {
    $stp->{Path} = skew $stp->{Path}, decode('%Y-%M-%D',$tok);
    mkdir($stp->{Path},0777) or return; #fail
  }

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

sub _stp_clean_house {
  my ($stp) = @_;
}

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

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

  my %log;
  $log->{Level}    = _stp_level($stp);
  $log->{String}   = _stp_string($stp);
  $log->{Token}    = { _have_a_toke_man() };
  $log->{Path}     = _stp_path($stp,$log->{Token});
  $log->{Handle}   = new FileHandle;
  $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),['STP','Clean']]
  );

  return %log;
}



 ##################################
 # ###########################
 ### RANDOM AWESOME FUNCTIONS

sub skew { #murder stupid paths
  my $skew = join('/',@_);
  $skew =~ s/(?:\\|\/)+/\//go;
  return $skew;
}

sub housekeep { #clean out logs
  my ($dir,$keep,$bydate) = @_;
  my @logs;

  find(
    {
      no_chdir => 1,
      wanted   => sub {
        return if -d $_;
        push(@logs,$_) if /\.log$/oi;
      },
    },
    $dir
  );
  unlink($_) or return foreach splice(@logs,0,0-$keep);
  return 1;
}



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

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

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 ($tak) = @_;
  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;
}

sub _update_tokens {
  my ($tok) = @_;
}

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)};
  }
}

sub last {
  my ($log) = @_;
  local ($tik) = $log->{token};
  my %LST = (
    'ERR' => _gettoke('E'),
    'MSG' => _gettoke('A'),
    'LVL' => _gettoke('L')
  );
}

sub reset {
}



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

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





 ##########################
 # ###################
 ### OBJECT FUNCTIONS

sub LOGCLOSE {
  my ($log) = @_;
}

sub LOGNOTE {
  my ($log) = @_;
}

sub LOGDEBUG {
  my ($log) = @_;
}

sub LOGWARN {
  my ($log) = @_;
}

sub LOGDIE {
  my ($log) = @_;
}



 #################################
 # ##########################
 ### 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!!



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

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
    },
  );
}



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

1;