package Bot::Cobalt::Utils;
$Bot::Cobalt::Utils::VERSION = '0.017008';
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_timestr
  timestr_to_secs

  mkpasswd
  passwdcmp

  color

  glob_grep
  glob_to_re
  glob_to_re_str
  rplprintf

  %COLORS
/;

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) {
      if ($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;
  return $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;

  return($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);

  return sprintf("%d days, %2.2d:%2.2d:%2.2d",
    $days, $hours, $mins, $sec
  );
}


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

1;
__END__
=pod

=head1 NAME

Bot::Cobalt::Utils - Utilities for Cobalt plugins

=head1 DESCRIPTION

Bot::Cobalt::Utils provides a set of simple utility functions for the 
L<Bot::Cobalt> core and plugins.

Plugin authors may wish to make use of these; importing the B<:ALL> tag 
from Bot::Cobalt::Utils will give you access to the entirety of this 
utility module, including useful string formatting tools, safe 
password hashing functions, etc.

You may also want to look at L<Bot::Cobalt::Common>, which exports most 
of this module.

=head1 USAGE

Import nothing:

  use Bot::Cobalt::Utils;
  
  my $hash = Bot::Cobalt::Utils::mkpasswd('things');

Import some things:

  use Bot::Cobalt::Utils qw/ mkpasswd passwdcmp /;
  
  my $hash = mkpasswd('things');

Import all the things:

  use Bot::Cobalt::Utils qw/ :ALL /;
  
  my $hash = mkpasswd('things', 'sha512');
  my $secs = timestr_to_secs('3h30m');
  . . .


See below for a list of exportable functions.


=head1 FUNCTIONS

=head2 Exportable functions

=over 

=item L</timestr_to_secs> - Convert a string into seconds

=item L</secs_to_timestr> - Convert seconds back into timestr

=item L</secs_to_str> - Convert seconds into a 'readable' string

=item L</color> - Add format/color to IRC messages

=item L</glob_to_re_str> - Convert Cobalt-style globs to regex strings

=item L</glob_to_re> - Convert Cobalt-style globs to compiled regexes

=item L</glob_grep> - Search an array or arrayref by glob

=item L</rplprintf> - Format portable langset reply strings

=item L</mkpasswd> - Create crypted passwords

=item L</passwdcmp> - Compare crypted passwords

=back


=head2 Date and Time

=head3 timestr_to_secs

Convert a string such as "2h10m" into seconds.

  my $delay_s = timestr_to_secs '1h33m10s';

Useful for dealing with timers.


=head3 secs_to_timestr

Turns seconds back into a timestring suitable for feeding to 
L</timestr_to_secs>:

  my $timestr = secs_to_timestr 820; ## -> 13m40s


=head3 secs_to_str

Convert a timestamp delta into a string.

Useful for uptime reporting, for example:

  my $delta = time() - $your_start_TS;
  my $uptime_str = secs_to_str $delta;



=head2 String Formatting

=head3 color

Add mIRC formatting and color codes to a string.

Valid formatting codes:

  NORMAL BOLD UNDERLINE REVERSE ITALIC

Valid color codes:

  WHITE BLACK BLUE GREEN RED BROWN PURPLE ORANGE YELLOW TEAL PINK
  LIGHT_CYAN LIGHT_BLUE LIGHT_GRAY LIGHT_GREEN

Format/color type can be passed in upper or lower case.

If passed just a color or format name, returns the control code.

If passed nothing at all, returns the 'NORMAL' reset code:

  my $str = color('bold') . "bold text" . color() . "normal text";

If passed a color or format name and a string, returns the formatted
string, terminated by NORMAL:

  my $formatted = color('red', "red text") . "normal text";

The hash B<%COLORS> is exported as part of I<:ALL>. Its keys are the 
same as the formatting/color names listed above. You should really use 
C<color()> instead.

=head3 glob_to_re_str

glob_to_re_str() converts Cobalt-style globs to regex strings.

  my $re = glob_to_re_str "th?ngs*stuff";
  ## or perhaps compile it:
  my $compiled_re = qr/$re/;

Perl regular expressions are very convenient and powerful. Unfortunately, 
that also means it's easy to make them eat up all of your CPU and thereby 
possibly break your system (or at least be annoying!)

For string search functions, it's better to use Cobalt-style globs:

  * == match any number of any character
  ? == match any single character
  + == match any single space
  leading ^  == anchor at start of string
  trailing $ == anchor at end of string

Standard regex syntax will be escaped and a translated regex returned.

The only exception is character classes; this is valid, for example:

  ^[a-z0-9]*$

=head3 glob_to_re

glob_to_re() converts Cobalt-style globs to B<compiled> regexes (qr//)

Using a compiled regex for matching is faster. Note that compiled regexes 
can also be serialized to B<YAML> using Bot::Cobalt::Serializer.

See L</glob_to_re_str> for details on globs. This function shares the same 
syntax.


=head3 glob_grep

glob_grep() can be used to search an array or an array reference for strings 
matching the specified glob:

  my @matches = glob_grep($glob, @array) || 'No matches!';
  my @matches = glob_grep($glob, $array_ref);

Returns the output of grep, which will be a list in list context or 
the number of matches in scalar context.


=head3 rplprintf

rplprintf() provides string formatting with replacement of arbitrary 
variables.

  rplprintf( $string, %vars_hash );
  rplprintf( $string, $vars_ref  );

The first argument to C<rplprintf> should be the template string. 
It may contain variables in the form of B<%var> or B<%var%> to be 
replaced.

The second argument is the hash (or hash reference) mapping B<%var> 
variables to strings.

For example:

  $string = "Access denied for %user (%host%)";
  $response = rplprintf(  $string,
      user => "Joe",
      host => "joe!joe@example.org",
  );  
  ## $response = 'Access denied for Joe (joe!joe@example.org)'

Intended for formatting langset RPLs before sending, but can be used for 
any simple string template.

Variable names can be terminated with a space or % -- both are demonstrated 
in the example above. You'll need to terminate with a trailing % if there 
are non-space characters following, as in the above example: I<(%host%)>

The same color/format strings as L</color> can be applied via %C_* vars:

  $string = "Access %C_BOLD%denied%C_NORMAL";
  $response = rplprintf( $string );

=head2 Password handling

=head3 mkpasswd

Simple interface for creating hashed passwords.

Defaults to creating a password using L<Crypt::Eksblowfish::Bcrypt> 
with a random salt and bcrypt work cost '08' -- this is a pretty sane 
default.

See L<App::bmkpasswd> for details; the built-in hash generation sugar 
was moved to that package.

bcrypt is strongly recommended; SHA and MD5 methods are also supported. 
Salts are always random.

  ## create a bcrypted password (work cost 08)
  ## bcrypt is blowfish with a work cost factor.
  ## if hashes are stolen, they'll be slow to break
  ## see http://codahale.com/how-to-safely-store-a-password/
  my $hashed = mkpasswd $password;

  ## you can specify method options . . .
  ## here's bcrypt with a lower work cost factor.
  ## (must be a two-digit power of 2, possibly padded with 0)
  my $hashed = mkpasswd $password, 'bcrypt', '06';

  ## Available methods:
  ##  bcrypt (preferred)
  ##  SHA-256 or -512 (req. modern libc or Crypt::Passwd::XS)
  ##  MD5 (fast, portable, weak)
  my $sha_passwd = mkpasswd $password, 'sha512';
  ## same as:
  my $sha_passwd = mkpasswd $password, 'SHA-512';


=head3 passwdcmp

Compare hashed passwords via L<App::bmkpasswd>.

Compatible with whatever methods C<mkpasswd> supports on the current 
system.

  return passwdcmp $password, $hashed;

Returns the hash if the cleartext password is a match. Otherwise returns 
boolean false.


=head1 AUTHOR

Jon Portnoy (avenj)

=cut
