src/PoCiCommon.pm

   1 # This is a transitional file
   2 #package POE::Component::IRC::Common;
   3 package src::PoCiCommon;
   4
   5 use strict;
   6 use warnings;
   7
   8 our $VERSION = '5.18';
   9
  10 require Exporter;
  11 use base qw(Exporter);
  12 our @EXPORT_OK = qw(
  13     u_irc l_irc parse_mode_line parse_ban_mask matches_mask matches_mask_array
  14     parse_user irc_ip_get_version irc_ip_is_ipv4 irc_ip_is_ipv6 has_color
  15     has_formatting strip_color strip_formatting NORMAL BOLD UNDERLINE REVERSE
  16     WHITE BLACK DARK_BLUE DARK_GREEN RED BROWN PURPLE ORANGE YELLOW LIGHT_GREEN
  17     TEAL CYAN LIGHT_BLUE MAGENTA DARK_GREY LIGHT_GREY
  18 );
  19 our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] );
  20
  21 my ($ERROR, $ERRNO);
  22
  23 use constant {
  24     NORMAL      => "\x0f",
  25
  26     # formatting
  27     BOLD        => "\x02",
  28     UNDERLINE   => "\x1f",
  29     REVERSE     => "\x16",
  30     ITALIC      => "\x1d",
  31     FIXED       => "\x11",
  32
  33     # mIRC colors
  34     WHITE       => "\x0300",
  35     BLACK       => "\x0301",
  36     DARK_BLUE   => "\x0302",
  37     DARK_GREEN  => "\x0303",
  38     RED         => "\x0304",
  39     BROWN       => "\x0305",
  40     PURPLE      => "\x0306",
  41     ORANGE      => "\x0307",
  42     YELLOW      => "\x0308",
  43     LIGHT_GREEN => "\x0309",
  44     TEAL        => "\x0310",
  45     CYAN        => "\x0311",
  46     LIGHT_BLUE  => "\x0312",
  47     MAGENTA     => "\x0313",
  48     DARK_GREY   => "\x0314",
  49     LIGHT_GREY  => "\x0315",
  50 };
  51
  52 sub u_irc {
  53     my $value = shift || return;
  54     my $type = shift || 'rfc1459';
  55     $type = lc $type;
  56
  57     if ( $type eq 'ascii' ) {
  58         $value =~ tr/a-z/A-Z/;
  59     }
  60     elsif ( $type eq 'strict-rfc1459' ) {
  61         $value =~ tr/a-z{}|/A-Z[]\\/;
  62     }
  63     else {
  64         $value =~ tr/a-z{}|^/A-Z[]\\~/;
  65     }
  66
  67     return $value;
  68 }
  69
  70 sub l_irc {
  71     my $value = shift || return;
  72     my $type = shift || 'rfc1459';
  73     $type = lc $type;
  74
  75     if ( $type eq 'ascii' ) {
  76         $value =~ tr/A-Z/a-z/;
  77     }
  78     elsif ( $type eq 'strict-rfc1459' ) {
  79         $value =~ tr/A-Z[]\\/a-z{}|/;
  80     }
  81     else {
  82         $value =~ tr/A-Z[]\\~/a-z{}|^/;
  83     }
  84
  85     return $value;
  86 }
  87
  88 sub parse_mode_line {
  89     my @args = @_;
  90
  91     my $chanmodes = [qw(beI k l imnpstaqr)];
  92     my $statmodes = 'ov';
  93     my $hashref = { };
  94     my $count = 0;
  95
  96     while (my $arg = shift @args) {
  97         if ( ref $arg eq 'ARRAY' ) {
  98            $chanmodes = $arg;
  99            next;
 100         }
 101         elsif ( ref $arg eq 'HASH' ) {
 102            $statmodes = join '', keys %{ $arg };
 103            next;
 104         }
 105         elsif ( $arg =~ /^(\+|-)/ or $count == 0 ) {
 106             my $action = '+';
 107             for my $char ( split (//,$arg) ) {
 108                 if ($char eq '+' or $char eq '-') {
 109                    $action = $char;
 110                 }
 111                 else {
 112                    push @{ $hashref->{modes} }, $action . $char;
 113                 }
 114
 115                 if ($char =~ /[$statmodes$chanmodes->[0]$chanmodes->[1]]/) {
 116                     push @{ $hashref->{args} }, shift @args;
 117                 }
 118
 119                 if ($action eq '+' && $char =~ /[$chanmodes->[2]]/) {
 120                     push @{ $hashref->{args} }, shift @args;
 121                 }
 122             }
 123         }
 124         else {
 125             push @{ $hashref->{args} }, $arg;
 126         }
 127         $count++;
 128     }
 129
 130     return $hashref;
 131 }
 132
 133 sub parse_ban_mask {
 134     my $arg = shift || return;
 135
 136     $arg =~ s/\x2a{2,}/\x2a/g;
 137     my @ban;
 138     my $remainder;
 139     if ($arg !~ /\x21/ and $arg =~ /\x40/) {
 140         $remainder = $arg;
 141     }
 142     else {
 143         ($ban[0], $remainder) = split /\x21/, $arg, 2;
 144     }
 145
 146     $remainder =~ s/\x21//g if defined $remainder;
 147     @ban[1..2] = split(/\x40/, $remainder, 2) if defined $remainder;
 148     $ban[2] =~ s/\x40//g if defined $ban[2];
 149
 150     for my $i (1..2) {
 151         $ban[$i] = '*' if !$ban[$i];
 152     }
 153
 154     return $ban[0] . '!' . $ban[1] . '@' . $ban[2];
 155 }
 156
 157 sub matches_mask_array {
 158     my ($masks, $matches, $mapping) = @_;
 159
 160     return if !$masks || !$matches;
 161     return if ref $masks ne 'ARRAY';
 162     return if ref $matches ne 'ARRAY';
 163     my $ref = { };
 164
 165     for my $mask ( @{ $masks } ) {
 166         for my $match ( @{ $matches } ) {
 167             if ( matches_mask($mask, $match, $mapping) ) {
 168                 push @{ $ref->{ $mask } }, $match;
 169             }
 170         }
 171     }
 172
 173     return $ref;
 174 }
 175
 176 sub matches_mask {
 177     my ($mask,$match,$mapping) = @_;
 178
 179     return if !$mask || !$match;
 180     $mask = parse_ban_mask($mask);
 181     $mask =~ s/\x2A+/\x2A/g;
 182
 183     my $umask = quotemeta u_irc( $mask, $mapping );
 184     $umask =~ s/\\\*/[\x01-\xFF]{0,}/g;
 185     $umask =~ s/\\\?/[\x01-\xFF]{1,1}/g;
 186     $match = u_irc $match, $mapping;
 187
 188     return 1 if $match =~ /^$umask$/;
 189     return;
 190 }
 191
 192 sub parse_user {
 193     my $user = shift || return;
 194     my ($n, $u, $h) = split /[!@]/, $user;
 195     return ($n, $u, $h) if wantarray();
 196     return $n;
 197 }
 198
 199 sub has_color {
 200     my $string = shift;
 201     return 1 if $string =~ /[\x03\x04]/;
 202     return;
 203 }
 204
 205 sub has_formatting {
 206     my $string = shift;
 207     return 1 if $string =~/[\x02\x1f\x16\x1d\x11]/;
 208     return;
 209 }
 210
 211 sub strip_color {
 212     my $string = shift;
 213
 214     # mIRC colors
 215     $string =~ s/\x03(?:,\d{1,2}|\d{1,2}(?:,\d{1,2})?)?//g;
 216     $string =~ s/\x0f//g;
 217
 218     # RGB colors supported by some clients
 219     $string =~ s/\x04[0-9a-fA-F]{0,6}//ig;
 220
 221     return $string;
 222 }
 223
 224 sub strip_formatting {
 225     my $string = shift;
 226     $string =~ s/[\x0f\x02\x1f\x16\x1d\x11]//g;
 227     return $string;
 228 }
 229
 230 #------------------------------------------------------------------------------
 231 # Subroutine ip_get_version
 232 # Purpose           : Get an IP version
 233 # Params            : IP address
 234 # Returns           : 4, 6, 0(don't know)
 235 sub irc_ip_get_version {
 236     my $ip = shift || return;
 237
 238     # If the address does not contain any ':', maybe it's IPv4
 239     return 4 if $ip !~ /:/ && irc_ip_is_ipv4($ip);
 240
 241     # Is it IPv6 ?
 242     return 6 if irc_ip_is_ipv6($ip);
 243
 244     return;
 245 }
 246
 247 #------------------------------------------------------------------------------
 248 # Subroutine ip_is_ipv4
 249 # Purpose           : Check if an IP address is version 4
 250 # Params            : IP address
 251 # Returns           : 1 (yes) or 0 (no)
 252 sub irc_ip_is_ipv4 {
 253     my $ip = shift || return;
 254
 255     # Check for invalid chars
 256     if ($ip !~ /^[\d\.]+$/) {
 257         $ERROR = "Invalid chars in IP $ip";
 258         $ERRNO = 107;
 259         return;
 260     }
 261
 262     if ($ip =~ /^\./) {
 263         $ERROR = "Invalid IP $ip - starts with a dot";
 264         $ERRNO = 103;
 265         return;
 266     }
 267
 268     if ($ip =~ /\.$/) {
 269         $ERROR = "Invalid IP $ip - ends with a dot";
 270         $ERRNO = 104;
 271         return;
 272     }
 273
 274     # Single Numbers are considered to be IPv4
 275     return 1 if $ip =~ /^(\d+)$/ && $1 < 256;
 276
 277     # Count quads
 278     my $n = ($ip =~ tr/\./\./);
 279
 280     # IPv4 must have from 1 to 4 quads
 281     if ($n <= 0 || $n > 4) {
 282         $ERROR = "Invalid IP address $ip";
 283         $ERRNO = 105;
 284         return;
 285     }
 286
 287     # Check for empty quads
 288     if ($ip =~ /\.\./) {
 289         $ERROR = "Empty quad in IP address $ip";
 290         $ERRNO = 106;
 291         return;
 292     }
 293
 294     for my $quad (split /\./, $ip) {
 295         # Check for invalid quads
 296         if ($quad < 0 || $quad >= 256) {
 297             $ERROR = "Invalid quad in IP address $ip - $_";
 298             $ERRNO = 107;
 299             return;
 300         }
 301     }
 302     return 1;
 303 }
 304
 305 #------------------------------------------------------------------------------
 306 # Subroutine ip_is_ipv6
 307 # Purpose           : Check if an IP address is version 6
 308 # Params            : IP address
 309 # Returns           : 1 (yes) or 0 (no)
 310 sub irc_ip_is_ipv6 {
 311     my $ip = shift || return;
 312
 313     # Count octets
 314     my $n = ($ip =~ tr/:/:/);
 315     return if ($n <= 0 || $n >= 8);
 316
 317     # $k is a counter
 318     my $k;
 319
 320     for my $octet (split /:/, $ip) {
 321         $k++;
 322
 323         # Empty octet ?
 324         next if $octet eq '';
 325
 326         # Normal v6 octet ?
 327         next if $octet =~ /^[a-f\d]{1,4}$/i;
 328
 329         # Last octet - is it IPv4 ?
 330         if ($k == $n + 1) {
 331             next if (ip_is_ipv4($octet));
 332         }
 333
 334         $ERROR = "Invalid IP address $ip";
 335         $ERRNO = 108;
 336         return;
 337     }
 338
 339     # Does the IP address start with : ?
 340     if ($ip =~ m/^:[^:]/) {
 341         $ERROR = "Invalid address $ip (starts with :)";
 342         $ERRNO = 109;
 343         return;
 344     }
 345
 346     # Does the IP address finish with : ?
 347     if ($ip =~ m/[^:]:$/) {
 348         $ERROR = "Invalid address $ip (ends with :)";
 349         $ERRNO = 110;
 350         return;
 351     }
 352
 353     # Does the IP address have more than one '::' pattern ?
 354     if ($ip =~ s/:(?=:)//g > 1) {
 355         $ERROR = "Invalid address $ip (More than one :: pattern)";
 356         $ERRNO = 111;
 357         return;
 358     }
 359
 360     return 1;
 361 }
 362
 363 1;
 364 __END__
 365
 366 =head1 NAME
 367
 368 src::PoCiCommon - provides a set of common functions for the
 369 infobot suite. Code originally from POE::Component::IRC::Common.
 370
 371 =head1 SYNOPSIS
 372
 373  use strict;
 374  use warnings;
 375
 376  use src::PoCiCommon qw( :ALL );
 377
 378  my $nickname = '^Lame|BOT[moo]';
 379  my $uppercase_nick = u_irc( $nickname );
 380  my $lowercase_nick = l_irc( $nickname );
 381
 382  my $mode_line = 'ov+b-i Bob sue stalin*!*@*';
 383  my $hashref = parse_mode_line( $mode_line );
 384
 385  my $banmask = 'stalin*';
 386  my $full_banmask = parse_ban_mask( $banmask );
 387
 388  if ( matches_mask( $full_banmask, 'stalin!joe@kremlin.ru' ) ) {
 389      print "EEK!";
 390  }
 391
 392  if ( has_color($message) ) {
 393     print 'COLOR CODE ALERT!";
 394  }
 395
 396  my $results_hashref = matches_mask_array( \@masks, \@items_to_match_against );
 397
 398  my $nick = parse_user( 'stalin!joe@kremlin.ru' );
 399  my ($nick, $user, $host) = parse_user( 'stalin!joe@kremlin.ru' );
 400
 401 =head1 DESCRIPTION
 402
 403 src::PoCiCommon provides a set of common functions for the infobot suite.
 404 Original code from POE::Component::IRC::Common. There are included functions
 405 for uppercase and lowercase nicknames/channelnames and for parsing mode lines
 406 and ban masks.
 407
 408 =head1 CONSTANTS
 409
 410 Use the following constants to add formatting and mIRC color codes to IRC
 411 messages.
 412
 413 Normal text:
 414
 415  NORMAL
 416
 417 Formatting:
 418
 419  BOLD
 420  UNDERLINE
 421  REVERSE
 422  ITALIC
 423  FIXED
 424
 425 Colors:
 426
 427  WHITE
 428  BLACK
 429  DARK_BLUE
 430  DARK_GREEN
 431  RED
 432  BROWN
 433  PURPLE
 434  ORANGE
 435  YELLOW
 436  LIGHT_GREEN
 437  TEAL
 438  CYAN
 439  LIGHT_BLUE
 440  MAGENTA
 441  DARK_GREY
 442  LIGHT_GREY
 443
 444 Individual formatting codes can be cancelled with their corresponding constant,
 445 but you can also cancel all of them at once with C<NORMAL>. To cancel the effect
 446 of previous color codes, you must use C<NORMAL>. which of course has the side
 447 effect of cancelling the effect of all previous formatting codes as well.
 448
 449  $irc->yield('This word is ' . YELLOW . 'yellow' . NORMAL
 450      . ' while this word is ' . BOLD . 'bold' . BOLD);
 451
 452  $irc->yield(UNDERLINE . BOLD . 'This sentence is both underlined and bold.'
 453      . NORMAL);
 454
 455
 456
 457 =head1 FUNCTIONS
 458
 459 =head2 C<u_irc>
 460
 461 Takes one mandatory parameter, a string to convert to IRC uppercase, and one
 462 optional parameter, the casemapping of the ircd ( which can be 'rfc1459',
 463 'strict-rfc1459' or 'ascii'. Default is 'rfc1459' ). Returns the IRC uppercase
 464 equivalent of the passed string.
 465
 466 =head2 C<l_irc>
 467
 468 Takes one mandatory parameter, a string to convert to IRC lowercase, and one
 469 optional parameter, the casemapping of the ircd ( which can be 'rfc1459',
 470 'strict-rfc1459' or 'ascii'. Default is 'rfc1459' ). Returns the IRC lowercase
 471 equivalent of the passed string.
 472
 473 =head2 C<parse_mode_line>
 474
 475 Takes a list representing an IRC mode line. Returns a hashref. If the modeline
 476 couldn't be parsed the hashref will be empty. On success the following keys
 477 will be available in the hashref:
 478
 479  'modes', an arrayref of normalised modes;
 480  'args', an arrayref of applicable arguments to the modes;
 481
 482 Example:
 483
 484  my $hashref = parse_mode_line( 'ov+b-i', 'Bob', 'sue', 'stalin*!*@*' );
 485
 486  # $hashref will be:
 487  {
 488     modes => [ '+o', '+v', '+b', '-i' ],
 489     args  => [ 'Bob', 'sue', 'stalin*!*@*' ],
 490  }
 491
 492 =head2 C<parse_ban_mask>
 493
 494 Takes one parameter, a string representing an IRC ban mask. Returns a
 495 normalised full banmask.
 496
 497 Example:
 498
 499  $fullbanmask = parse_ban_mask( 'stalin*' );
 500
 501  # $fullbanmask will be: 'stalin*!*@*';
 502
 503 =head2 C<matches_mask>
 504
 505 Takes two parameters, a string representing an IRC mask ( it'll be processed
 506 with parse_ban_mask() to ensure that it is normalised ) and something to match
 507 against the IRC mask, such as a nick!user@hostname string. Returns a true
 508 value if they match, a false value otherwise. Optionally, one may pass the
 509 casemapping (see L<C<u_irc()>|/"u_irc">), as this function uses C<u_irc()>
 510 internally.
 511
 512 =head2 C<matches_mask_array>
 513
 514 Takes two array references, the first being a list of strings representing
 515 IRC masks, the second a list of somethings to test against the masks. Returns
 516 an empty hashref if there are no matches. Otherwise, the keys will be the
 517 masks matched, each value being an arrayref of the strings that matched it.
 518 Optionally, one may pass the casemapping (see L<C<u_irc()>|/"u_irc">), as
 519 this function uses C<u_irc()> internally.
 520
 521 =head2 C<parse_user>
 522
 523 Takes one parameter, a string representing a user in the form
 524 nick!user@hostname. In a scalar context it returns just the nickname.
 525 In a list context it returns a list consisting of the nick, user and hostname,
 526 respectively.
 527
 528 =head2 C<has_color>
 529
 530 Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC
 531 color codes, 0 otherwise. Useful if you want your bot to kick users for
 532 (ab)using colors. :)
 533
 534 =head2 C<has_formatting>
 535
 536 Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC
 537 formatting codes, 0 otherwise.
 538
 539 =head2 C<strip_color>
 540
 541 Takes one paramter, a string of IRC text. Returns the string stripped of all
 542 IRC color codes. Due to the fact that both color and formatting codes can
 543 be cancelled with the same character, this might strip more than you hoped for
 544 if the string contains both color and formatting codes. Stripping both will
 545 always do what you expect it to.
 546
 547 =head2 C<strip_formatting>
 548
 549 Takes one paramter, a string of IRC text. Returns the string stripped of all
 550 IRC formatting codes. Due to the fact that both color and formatting codes can
 551 be cancelled with the same character, this might strip more than you hoped for
 552 if the string contains both color and formatting codes. Stripping both will
 553 always do what you expect it to.
 554
 555 =head2 C<irc_ip_get_version>
 556
 557 Try to guess the IP version of an IP address.
 558
 559 Params: IP address
 560 Returns: 4, 6, 0(unable to determine)
 561
 562 C<$version = ip_get_version ($ip)>
 563
 564 =head2 C<irc_ip_is_ipv4>
 565
 566 Check if an IP address is of type 4.
 567
 568 Params: IP address
 569 Returns: 1 (yes) or 0 (no)
 570
 571 C<ip_is_ipv4($ip) and print "$ip is IPv4";>
 572
 573 =head2 C<irc_ip_is_ipv6>
 574
 575 Check if an IP address is of type 6.
 576
 577 Params: IP address
 578 Returns: 1 (yes) or 0 (no)
 579
 580  ip_is_ipv6($ip) && print "$ip is IPv6";
 581
 582 =head1 AUTHOR
 583
 584 Dan 'troubled' McGrath
 585
 586 This whole module is shamelessly 'borrowed' from L<POE::Component::IRC::Common>
 587 by Chris 'BinGOs' Williams
 588
 589 =head1 SEE ALSO
 590
 591 L<POE::Component::IRC::Common>
 592
 593 L<POE::Component::IRC|POE::Component::IRC>
 594
 595 L<Net::IP|Net::IP>
 596
 597 =cut