1 # This is a transitional file
2 #package POE::Component::IRC::Common;
3 package src::PoCiCommon;
11 use base qw(Exporter);
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
19 our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] );
36 DARK_BLUE => "\x0302",
37 DARK_GREEN => "\x0303",
43 LIGHT_GREEN => "\x0309",
46 LIGHT_BLUE => "\x0312",
48 DARK_GREY => "\x0314",
49 LIGHT_GREY => "\x0315",
53 my $value = shift || return;
54 my $type = shift || 'rfc1459';
57 if ( $type eq 'ascii' ) {
58 $value =~ tr/a-z/A-Z/;
60 elsif ( $type eq 'strict-rfc1459' ) {
61 $value =~ tr/a-z{}|/A-Z[]\\/;
64 $value =~ tr/a-z{}|^/A-Z[]\\~/;
71 my $value = shift || return;
72 my $type = shift || 'rfc1459';
75 if ( $type eq 'ascii' ) {
76 $value =~ tr/A-Z/a-z/;
78 elsif ( $type eq 'strict-rfc1459' ) {
79 $value =~ tr/A-Z[]\\/a-z{}|/;
82 $value =~ tr/A-Z[]\\~/a-z{}|^/;
91 my $chanmodes = [qw(beI k l imnpstaqr)];
96 while (my $arg = shift @args) {
97 if ( ref $arg eq 'ARRAY' ) {
101 elsif ( ref $arg eq 'HASH' ) {
102 $statmodes = join '', keys %{ $arg };
105 elsif ( $arg =~ /^(\+|-)/ or $count == 0 ) {
107 for my $char ( split (//,$arg) ) {
108 if ($char eq '+' or $char eq '-') {
112 push @{ $hashref->{modes} }, $action . $char;
115 if ($char =~ /[$statmodes$chanmodes->[0]$chanmodes->[1]]/) {
116 push @{ $hashref->{args} }, shift @args;
119 if ($action eq '+' && $char =~ /[$chanmodes->[2]]/) {
120 push @{ $hashref->{args} }, shift @args;
125 push @{ $hashref->{args} }, $arg;
134 my $arg = shift || return;
136 $arg =~ s/\x2a{2,}/\x2a/g;
139 if ($arg !~ /\x21/ and $arg =~ /\x40/) {
143 ($ban[0], $remainder) = split /\x21/, $arg, 2;
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];
151 $ban[$i] = '*' if !$ban[$i];
154 return $ban[0] . '!' . $ban[1] . '@' . $ban[2];
157 sub matches_mask_array {
158 my ($masks, $matches, $mapping) = @_;
160 return if !$masks || !$matches;
161 return if ref $masks ne 'ARRAY';
162 return if ref $matches ne 'ARRAY';
165 for my $mask ( @{ $masks } ) {
166 for my $match ( @{ $matches } ) {
167 if ( matches_mask($mask, $match, $mapping) ) {
168 push @{ $ref->{ $mask } }, $match;
177 my ($mask,$match,$mapping) = @_;
179 return if !$mask || !$match;
180 $mask = parse_ban_mask($mask);
181 $mask =~ s/\x2A+/\x2A/g;
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;
188 return 1 if $match =~ /^$umask$/;
193 my $user = shift || return;
194 my ($n, $u, $h) = split /[!@]/, $user;
195 return ($n, $u, $h) if wantarray();
201 return 1 if $string =~ /[\x03\x04]/;
207 return 1 if $string =~/[\x02\x1f\x16\x1d\x11]/;
215 $string =~ s/\x03(?:,\d{1,2}|\d{1,2}(?:,\d{1,2})?)?//g;
216 $string =~ s/\x0f//g;
218 # RGB colors supported by some clients
219 $string =~ s/\x04[0-9a-fA-F]{0,6}//ig;
224 sub strip_formatting {
226 $string =~ s/[\x0f\x02\x1f\x16\x1d\x11]//g;
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;
238 # If the address does not contain any ':', maybe it's IPv4
239 return 4 if $ip !~ /:/ && irc_ip_is_ipv4($ip);
242 return 6 if irc_ip_is_ipv6($ip);
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)
253 my $ip = shift || return;
255 # Check for invalid chars
256 if ($ip !~ /^[\d\.]+$/) {
257 $ERROR = "Invalid chars in IP $ip";
263 $ERROR = "Invalid IP $ip - starts with a dot";
269 $ERROR = "Invalid IP $ip - ends with a dot";
274 # Single Numbers are considered to be IPv4
275 return 1 if $ip =~ /^(\d+)$/ && $1 < 256;
278 my $n = ($ip =~ tr/\./\./);
280 # IPv4 must have from 1 to 4 quads
281 if ($n <= 0 || $n > 4) {
282 $ERROR = "Invalid IP address $ip";
287 # Check for empty quads
289 $ERROR = "Empty quad in IP address $ip";
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 - $_";
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)
311 my $ip = shift || return;
314 my $n = ($ip =~ tr/:/:/);
315 return if ($n <= 0 || $n >= 8);
320 for my $octet (split /:/, $ip) {
324 next if $octet eq '';
327 next if $octet =~ /^[a-f\d]{1,4}$/i;
329 # Last octet - is it IPv4 ?
331 next if (ip_is_ipv4($octet));
334 $ERROR = "Invalid IP address $ip";
339 # Does the IP address start with : ?
340 if ($ip =~ m/^:[^:]/) {
341 $ERROR = "Invalid address $ip (starts with :)";
346 # Does the IP address finish with : ?
347 if ($ip =~ m/[^:]:$/) {
348 $ERROR = "Invalid address $ip (ends with :)";
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)";
368 src::PoCiCommon - provides a set of common functions for the
369 infobot suite. Code originally from POE::Component::IRC::Common.
376 use src::PoCiCommon qw( :ALL );
378 my $nickname = '^Lame|BOT[moo]';
379 my $uppercase_nick = u_irc( $nickname );
380 my $lowercase_nick = l_irc( $nickname );
382 my $mode_line = 'ov+b-i Bob sue stalin*!*@*';
383 my $hashref = parse_mode_line( $mode_line );
385 my $banmask = 'stalin*';
386 my $full_banmask = parse_ban_mask( $banmask );
388 if ( matches_mask( $full_banmask, 'stalin!joe@kremlin.ru' ) ) {
392 if ( has_color($message) ) {
393 print 'COLOR CODE ALERT!";
396 my $results_hashref = matches_mask_array( \@masks, \@items_to_match_against );
398 my $nick = parse_user( 'stalin!joe@kremlin.ru' );
399 my ($nick, $user, $host) = parse_user( 'stalin!joe@kremlin.ru' );
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
410 Use the following constants to add formatting and mIRC color codes to IRC
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.
449 $irc->yield('This word is ' . YELLOW . 'yellow' . NORMAL
450 . ' while this word is ' . BOLD . 'bold' . BOLD);
452 $irc->yield(UNDERLINE . BOLD . 'This sentence is both underlined and bold.'
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.
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.
473 =head2 C<parse_mode_line>
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:
479 'modes', an arrayref of normalised modes;
480 'args', an arrayref of applicable arguments to the modes;
484 my $hashref = parse_mode_line( 'ov+b-i', 'Bob', 'sue', 'stalin*!*@*' );
488 modes => [ '+o', '+v', '+b', '-i' ],
489 args => [ 'Bob', 'sue', 'stalin*!*@*' ],
492 =head2 C<parse_ban_mask>
494 Takes one parameter, a string representing an IRC ban mask. Returns a
495 normalised full banmask.
499 $fullbanmask = parse_ban_mask( 'stalin*' );
501 # $fullbanmask will be: 'stalin*!*@*';
503 =head2 C<matches_mask>
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()>
512 =head2 C<matches_mask_array>
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.
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,
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
534 =head2 C<has_formatting>
536 Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC
537 formatting codes, 0 otherwise.
539 =head2 C<strip_color>
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.
547 =head2 C<strip_formatting>
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.
555 =head2 C<irc_ip_get_version>
557 Try to guess the IP version of an IP address.
560 Returns: 4, 6, 0(unable to determine)
562 C<$version = ip_get_version ($ip)>
564 =head2 C<irc_ip_is_ipv4>
566 Check if an IP address is of type 4.
569 Returns: 1 (yes) or 0 (no)
571 C<ip_is_ipv4($ip) and print "$ip is IPv4";>
573 =head2 C<irc_ip_is_ipv6>
575 Check if an IP address is of type 6.
578 Returns: 1 (yes) or 0 (no)
580 ip_is_ipv6($ip) && print "$ip is IPv6";
584 Dan 'troubled' McGrath
586 This whole module is shamelessly 'borrowed' from L<POE::Component::IRC::Common>
587 by Chris 'BinGOs' Williams
591 L<POE::Component::IRC::Common>
593 L<POE::Component::IRC|POE::Component::IRC>