File Coverage

blib/lib/IRC/Toolkit/Case.pm

Criterion	Covered	Total	%
statement	45	51	88.2
branch	10	12	83.3
condition	9	10	90.0
subroutine	9	9	100.0
pod	4	4	100.0
total	77	86	89.5

package IRC::Toolkit::Case;
$IRC::Toolkit::Case::VERSION = '0.092002';
use strictures 2;
no warnings 'once';
use Carp 'carp';

use parent 'Exporter::Tiny';
our @EXPORT = qw/
  lc_irc
  uc_irc
  eq_irc

  rfc1459

  irc_str
/;


use Sub::Infix;
*rfc1459 = &infix(sub { eq_irc( $_[0], $_[1], 'rfc1459' ) });


## The prototypes are unfortunate, but I pulled these out of an old
## and very large bot project ... and was too scared to remove them.

sub lc_irc ($;$) {
  my ($string, $casemap) = @_;
  $casemap = lc( $casemap || 'rfc1459' );

  CASE: {
    if ($casemap eq 'rfc1459') {
      $string =~ tr/A-Z[]\\~/a-z{}|^/;
      last CASE
    }

    if ($casemap eq 'strict-rfc1459' || $casemap eq 'strict') {
      $string =~ tr/A-Z[]\\/a-z{}|/;
      last CASE
    }

    if ($casemap eq 'ascii') {
      $string =~ tr/A-Z/a-z/;
      last CASE
    }

    carp "Unknown CASEMAP $casemap, defaulted to rfc1459";
    $casemap = 'rfc1459';
    redo CASE
  }

  $string
}

sub uc_irc ($;$) {
  my ($string, $casemap) = @_;
  $casemap = lc( $casemap || 'rfc1459' );

  CASE: {
    if ($casemap eq 'rfc1459') {
      $string =~ tr/a-z{}|^/A-Z[]\\~/;
      last CASE
    }

    if ($casemap eq 'strict-rfc1459' || $casemap eq 'strict') {
      $string =~ tr/a-z{}|/A-Z[]\\/;
      last CASE
    }

    if ($casemap eq 'ascii') {
      $string =~ tr/a-z/A-Z/;
      last CASE
    }

    carp "Unknown CASEMAP $casemap, defaulted to rfc1459";
    $casemap = 'rfc1459';
    redo CASE
  }

  $string
}

sub eq_irc ($$;$) {
  my ($first, $second, $casemap) = @_;
  uc_irc($first, $casemap) eq uc_irc($second, $casemap);
}

sub irc_str {
  require IRC::Toolkit::Case::MappedString;
  IRC::Toolkit::Case::MappedString->new(@_)
}

print
  qq[ Also, every now and then I talk about a game I've enjoyed],
  qq[ and rofer doesn't have time for it, Capn v1.02 doesn't understand],
  qq[ the human concept of fun/entertainment, c[_] only plays retro-games],
  qq[ made in his native homeland of Moria and avenj would rather shoot],
  qq[ rifles while vaping\n]
unless caller; 1;

=pod

=head1 NAME

IRC::Toolkit::Case - IRC case-folding utilities

=head1 SYNOPSIS

  use IRC::Toolkit::Case;

  my $lower = lc_irc( $string, 'rfc1459' );

  my $upper = uc_irc( $string, 'ascii' );

  if (eq_irc($first, $second, 'strict-rfc1459')) {
    ...
  }

  # Or use the '|rfc1459|' operator if using RFC1459 rules:
  if ($first |rfc1459| $second) {

  }

=head1 DESCRIPTION

IRC case-folding utilities.

IRC daemons typically announce their casemap in B (via the
B directive). This should be one of C,
C, or C:

  'ascii'           a-z      -->  A-Z
  'rfc1459'         a-z{}|^  -->  A-Z[]\~   (default)
  'strict-rfc1459'  a-z{}|   -->  A-Z[]\

If told to convert/compare an unknown casemap, these functions will warn and
default to RFC1459 rules.

If you're building a class that tracks an IRC casemapping and manipulates
strings accordingly, you may also want to see L.

=head2 rfc1459 operator

The infix operator C<|rfc1459|> is provided as a convenience for string
comparison (using RFC1459 rules):

  if ($first |rfc1459| $second) { ... }
  # Same as:
  if (eq_irc($first, $second)) { ... }

=head2 lc_irc

Takes a string and an optional casemap.

Returns the lowercased string.

=head2 uc_irc

Takes a string and an optional casemap.

Returns the uppercased string.

=head2 eq_irc

Takes a pair of strings and an optional casemap.

Returns boolean true if the strings are equal
(per the rules specified by the given casemap).

=head2 irc_str

  my $str = irc_str( strict => 'Nick^[Abc]' );
  if ( $str eq 'nick^{abc}' ) {
    # true
  }

Takes a casemap and string; if only one argument is provided, it is taken to
be the string and a C casemap is assumed.

Produces overloaded objects (see L) that can
be stringified or compared; string comparison operators use the specified
casemap.

=head1 AUTHOR

Jon Portnoy

Inspired by L, copyright Chris Williams, Hinrik et al

Licensed under the same terms as Perl.

=cut