File Coverage

blib/lib/Bot/Cobalt/Utils.pm

Criterion	Covered	Total	%
statement	133	147	90.4
branch	59	86	68.6
condition	5	8	62.5
subroutine	18	18	100.0
pod	11	11	100.0
total	226	270	83.7

package Bot::Cobalt::Utils;
$Bot::Cobalt::Utils::VERSION = '0.021003';
use strictures 2;
use Carp;
use Scalar::Util 'reftype';

use App::bmkpasswd ();

use parent 'Exporter::Tiny';

our @EXPORT_OK = qw/
  secs_to_str
  secs_to_str_y
  secs_to_timestr
  timestr_to_secs

  mkpasswd
  passwdcmp

  color

  glob_grep
  glob_to_re
  glob_to_re_str
  rplprintf
/;

our %EXPORT_TAGS = (
  ALL => [ @EXPORT_OK ],
);


## codes mostly borrowed from IRC::Utils
our %COLORS = (
  NORMAL      => "\x0f",

  BOLD        => "\x02",
  UNDERLINE   => "\x1f",
  REVERSE     => "\x16",
  ITALIC      => "\x1d",

  WHITE       => "\x0300",
  BLACK       => "\x0301",
  BLUE        => "\x0302",
  GREEN       => "\x0303",
  RED         => "\x0304",
  BROWN       => "\x0305",
  PURPLE      => "\x0306",
  ORANGE      => "\x0307",
  YELLOW      => "\x0308",
  TEAL        => "\x0310",
  PINK        => "\x0313",
  GREY        => "\x0314",
  GRAY        => "\x0314",

  LIGHT_BLUE  => "\x0312",
  LIGHT_CYAN  => "\x0311",
  LIGHT_GREEN => "\x0309",
  LIGHT_GRAY  => "\x0315",
  LIGHT_GREY  => "\x0315",
);

my %default_fmt_vars;
for my $color (keys %COLORS) {
  my $fmtvar = 'C_'.$color;
  $default_fmt_vars{$fmtvar} = $COLORS{$color};
}

## String formatting, usually for langsets:
sub rplprintf {
  my $string = shift;
  return '' unless $string;

  ## rplprintf( $string, $vars )
  ## returns empty string if no string is specified.
  ##
  ## variables can be terminated with % or a space:
  ## rplprintf( "Error for %user%: %err")
  ##
  ## used for formatting lang RPLs
  ## $vars should be a hash keyed by variable, f.ex:
  ##   'user' => $username,
  ##   'err'  => $error,

  my %vars;

  if (@_ > 1) {
    my %args = @_;
    %vars = ( %default_fmt_vars, %args );
  } else {
    if (reftype $_[0] eq 'HASH') {
      %vars = ( %default_fmt_vars, %{$_[0]} );
    } else {
      confess "rplprintf() expects a hash"
    }
  }

  my $repl = sub {
    ## _repl($1, $2, $vars)
    my ($orig, $match) = @_;
    defined $vars{$match} ? $vars{$match} : $orig
  };

  my $regex = qr/(%([^\s%]+)%?)/;

  $string =~ s/$regex/$repl->($1, $2)/ge;

  $string
}


## Glob -> regex functions:

sub glob_grep ($;@) {
  my $glob = shift;
  confess "glob_grep called with no arguments!"
    unless defined $glob;

  my @array = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_ ;

  my $re = glob_to_re($glob);

  grep { m/$re/ } @array
}

sub glob_to_re ($) {
  my ($glob) = @_;
  confess "glob_to_re called with no arguments!"
    unless defined $glob;

  my $re = glob_to_re_str($glob);

  qr/$re/
}

sub glob_to_re_str ($) {
  ## Currently allows:
  ##   *  == .*
  ##   ?  == .
  ##   +  == literal space
  ##   leading ^ (beginning of str) is accepted
  ##   so is trailing $
  ##   char classes are accepted
  my ($glob) = @_;
  confess "glob_to_re_str called with no arguments!"
    unless defined $glob;

  my($re, $in_esc);
  my ($first, $pos) = (1, 0);
  my @chars = split '', $glob;
  for my $ch (@chars) {
    ++$pos;
    my $last = 1 if $pos == @chars;

    ## Leading ^ (start) is OK:
    if ($first) {
      if ($ch eq '^') {
        $re .= '^' ;
        next
      }
      $first = 0;
    ## So is trailing $ (end):
    } elsif ($last && $ch eq '$') {
      $re .= '$' ;
      last
    }

    ## Escape metas:
    if (grep { $_ eq $ch } qw/ . ( ) | ^ $ @ % { } /) {
      $re .= "\\$ch" ;
      $in_esc = 0;
      next
    }

    ## Handle * ? + wildcards:
    if ($ch eq '*') {
      $re .= $in_esc ? '\*' : '.*' ;
      $in_esc = 0;
      next
    }
    if ($ch eq '?') {
      $re .= $in_esc ? '\?' : '.' ;
      $in_esc = 0;
      next
    }
    if ($ch eq '+') {
      $re .= $in_esc ? '\+' : '\s' ;
      $in_esc = 0;
      next
    }
    if ( $ch eq '[' || $ch eq ']' ) {
      $re .= $in_esc ? "\\$ch" : $ch ;
      $in_esc = 0;
      next
    }

    ## Switch on/off escaping:
    if ($ch eq "\\") {
      if ($in_esc) {
        $re .= "\\\\";
        $in_esc = 0;
      } else { $in_esc = 1; }
      next
    }

    $re .= $ch;
    $in_esc = 0;
  }

  $re
}


## IRC color codes:
sub color ($;$) {
  ## color($format, $str)
  ## implements mirc formatting codes, against my better judgement
  ## if format is unspecified, returns NORMAL

  ## interpolate bold, reset to NORMAL after:
  ## $str = color('bold') . "Text" . color;
  ##  -or-
  ## format specified strings, resetting NORMAL after:
  ## $str = color('bold', "Some text"); # bold text ending in normal

  my ($format, $str) = @_;
  $format = uc($format||'normal');

  my $selected = $COLORS{$format};

  carp "Invalid COLOR $format passed to color()"
    unless $selected;

  return $selected . $str . $COLORS{NORMAL} if $str;
  $selected || $COLORS{NORMAL};
}


## Time/date ops:
sub timestr_to_secs ($) {
  ## turn something like 2h3m30s into seconds
  my ($timestr) = @_;

  unless ($timestr) {
    carp "timestr_to_secs() received a false value";
    return 0
  }

  ## maybe just seconds:
  return $timestr if $timestr =~ /^[0-9]+$/;

  my @chunks = $timestr =~ m/([0-9]+)([dhms])/gc;

  my $secs = 0;
  while ( my ($ti, $unit) = splice @chunks, 0, 2 ) {
    UNIT: {
      if ($unit eq 'd') {
        $secs += $ti * 86400;
        last UNIT
      }

      if ($unit eq 'h') {
        $secs += $ti * 3600;
        last UNIT
      }

      if ($unit eq 'm') {
        $secs += $ti * 60;
        last UNIT
      }

      $secs += $ti;
    }
  }

  $secs
}

sub _time_breakdown ($) {
  my ($diff) = @_;
  return unless defined $diff;

  my $days   = int $diff / 86400;
  my $sec    = $diff % 86400;
  my $hours  = int $sec / 3600;
  $sec %= 3600;
  my $mins   = int $sec / 60;
  $sec %= 60;

  ($days, $hours, $mins, $sec)
}

sub secs_to_timestr ($) {
  my ($diff) = @_;
  return unless defined $diff;
  my ($days, $hours, $mins, $sec) = _time_breakdown($diff);

  my $str;
  $str .= $days  .'d' if $days;
  $str .= $hours .'h' if $hours;
  $str .= $mins  .'m' if $mins;
  $str .= $sec   .'s' if $sec;

  $str
}

sub secs_to_str ($) {
  ## turn seconds into a string like '0 days, 00:00:00'
  my ($diff) = @_;
  return unless defined $diff;
  my ($days, $hours, $mins, $sec) = _time_breakdown($diff);
  my $plural = $days == 1 ? 'day' : 'days';
  sprintf "%d $plural, %2.2d:%2.2d:%2.2d", $days, $hours, $mins, $sec
}

sub secs_to_str_y {
  my ($diff) = @_;
  return unless defined $diff;
  my ($days, $hrs, $mins, $sec) = _time_breakdown($diff);
  my $yrs = int $days / 365;
  $days %= 365;
  my $plural_y = $yrs > 1 ? 'years' : 'year';
  my $plural_d = $days == 1 ? 'day' : 'days';
  $yrs ?
    sprintf "%d $plural_y, %d $plural_d, %2.2d:%2.2d:%2.2d",
      $yrs, $days, $hrs, $mins, $sec
    : sprintf "%d $plural_d, %2.2d:%2.2d:%2.2d",
        $days, $hrs, $mins, $sec
}


## App::bmkpasswd stubs as of 00_35
sub mkpasswd  ($;@) { App::bmkpasswd::mkpasswd(@_) }
sub passwdcmp ($$) { App::bmkpasswd::passwdcmp(@_) }

1;
__END__