From: djmcgrath Date: Mon, 26 Jan 2009 21:37:15 +0000 (+0000) Subject: * Added a forked copy of PoCi Common with altered filename to avoid dupe install... X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=d427cfb53ce7f89be6cbc6462bf5f8dbd9e09c29;p=infobot.git * Added a forked copy of PoCi Common with altered filename to avoid dupe install issues pending administrative decisions on POE and some testing git-svn-id: https://svn.code.sf.net/p/infobot/code/trunk@1864 c11ca15a-4712-0410-83d8-924469b57eb5 --- diff --git a/src/PoCiCommon.pm b/src/PoCiCommon.pm new file mode 100644 index 0000000..058a1fb --- /dev/null +++ b/src/PoCiCommon.pm @@ -0,0 +1,597 @@ +# This is a transitional file +#package POE::Component::IRC::Common; +package src::PoCiCommon; + +use strict; +use warnings; + +our $VERSION = '5.18'; + +require Exporter; +use base qw(Exporter); +our @EXPORT_OK = qw( + u_irc l_irc parse_mode_line parse_ban_mask matches_mask matches_mask_array + parse_user irc_ip_get_version irc_ip_is_ipv4 irc_ip_is_ipv6 has_color + has_formatting strip_color strip_formatting NORMAL BOLD UNDERLINE REVERSE + WHITE BLACK DARK_BLUE DARK_GREEN RED BROWN PURPLE ORANGE YELLOW LIGHT_GREEN + TEAL CYAN LIGHT_BLUE MAGENTA DARK_GREY LIGHT_GREY +); +our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); + +my ($ERROR, $ERRNO); + +use constant { + NORMAL => "\x0f", + + # formatting + BOLD => "\x02", + UNDERLINE => "\x1f", + REVERSE => "\x16", + ITALIC => "\x1d", + FIXED => "\x11", + + # mIRC colors + WHITE => "\x0300", + BLACK => "\x0301", + DARK_BLUE => "\x0302", + DARK_GREEN => "\x0303", + RED => "\x0304", + BROWN => "\x0305", + PURPLE => "\x0306", + ORANGE => "\x0307", + YELLOW => "\x0308", + LIGHT_GREEN => "\x0309", + TEAL => "\x0310", + CYAN => "\x0311", + LIGHT_BLUE => "\x0312", + MAGENTA => "\x0313", + DARK_GREY => "\x0314", + LIGHT_GREY => "\x0315", +}; + +sub u_irc { + my $value = shift || return; + my $type = shift || 'rfc1459'; + $type = lc $type; + + if ( $type eq 'ascii' ) { + $value =~ tr/a-z/A-Z/; + } + elsif ( $type eq 'strict-rfc1459' ) { + $value =~ tr/a-z{}|/A-Z[]\\/; + } + else { + $value =~ tr/a-z{}|^/A-Z[]\\~/; + } + + return $value; +} + +sub l_irc { + my $value = shift || return; + my $type = shift || 'rfc1459'; + $type = lc $type; + + if ( $type eq 'ascii' ) { + $value =~ tr/A-Z/a-z/; + } + elsif ( $type eq 'strict-rfc1459' ) { + $value =~ tr/A-Z[]\\/a-z{}|/; + } + else { + $value =~ tr/A-Z[]\\~/a-z{}|^/; + } + + return $value; +} + +sub parse_mode_line { + my @args = @_; + + my $chanmodes = [qw(beI k l imnpstaqr)]; + my $statmodes = 'ov'; + my $hashref = { }; + my $count = 0; + + while (my $arg = shift @args) { + if ( ref $arg eq 'ARRAY' ) { + $chanmodes = $arg; + next; + } + elsif ( ref $arg eq 'HASH' ) { + $statmodes = join '', keys %{ $arg }; + next; + } + elsif ( $arg =~ /^(\+|-)/ or $count == 0 ) { + my $action = '+'; + for my $char ( split (//,$arg) ) { + if ($char eq '+' or $char eq '-') { + $action = $char; + } + else { + push @{ $hashref->{modes} }, $action . $char; + } + + if ($char =~ /[$statmodes$chanmodes->[0]$chanmodes->[1]]/) { + push @{ $hashref->{args} }, shift @args; + } + + if ($action eq '+' && $char =~ /[$chanmodes->[2]]/) { + push @{ $hashref->{args} }, shift @args; + } + } + } + else { + push @{ $hashref->{args} }, $arg; + } + $count++; + } + + return $hashref; +} + +sub parse_ban_mask { + my $arg = shift || return; + + $arg =~ s/\x2a{2,}/\x2a/g; + my @ban; + my $remainder; + if ($arg !~ /\x21/ and $arg =~ /\x40/) { + $remainder = $arg; + } + else { + ($ban[0], $remainder) = split /\x21/, $arg, 2; + } + + $remainder =~ s/\x21//g if defined $remainder; + @ban[1..2] = split(/\x40/, $remainder, 2) if defined $remainder; + $ban[2] =~ s/\x40//g if defined $ban[2]; + + for my $i (1..2) { + $ban[$i] = '*' if !$ban[$i]; + } + + return $ban[0] . '!' . $ban[1] . '@' . $ban[2]; +} + +sub matches_mask_array { + my ($masks, $matches, $mapping) = @_; + + return if !$masks || !$matches; + return if ref $masks ne 'ARRAY'; + return if ref $matches ne 'ARRAY'; + my $ref = { }; + + for my $mask ( @{ $masks } ) { + for my $match ( @{ $matches } ) { + if ( matches_mask($mask, $match, $mapping) ) { + push @{ $ref->{ $mask } }, $match; + } + } + } + + return $ref; +} + +sub matches_mask { + my ($mask,$match,$mapping) = @_; + + return if !$mask || !$match; + $mask = parse_ban_mask($mask); + $mask =~ s/\x2A+/\x2A/g; + + my $umask = quotemeta u_irc( $mask, $mapping ); + $umask =~ s/\\\*/[\x01-\xFF]{0,}/g; + $umask =~ s/\\\?/[\x01-\xFF]{1,1}/g; + $match = u_irc $match, $mapping; + + return 1 if $match =~ /^$umask$/; + return; +} + +sub parse_user { + my $user = shift || return; + my ($n, $u, $h) = split /[!@]/, $user; + return ($n, $u, $h) if wantarray(); + return $n; +} + +sub has_color { + my $string = shift; + return 1 if $string =~ /[\x03\x04]/; + return; +} + +sub has_formatting { + my $string = shift; + return 1 if $string =~/[\x02\x1f\x16\x1d\x11]/; + return; +} + +sub strip_color { + my $string = shift; + + # mIRC colors + $string =~ s/\x03(?:,\d{1,2}|\d{1,2}(?:,\d{1,2})?)?//g; + $string =~ s/\x0f//g; + + # RGB colors supported by some clients + $string =~ s/\x04[0-9a-fA-F]{0,6}//ig; + + return $string; +} + +sub strip_formatting { + my $string = shift; + $string =~ s/[\x0f\x02\x1f\x16\x1d\x11]//g; + return $string; +} + +#------------------------------------------------------------------------------ +# Subroutine ip_get_version +# Purpose : Get an IP version +# Params : IP address +# Returns : 4, 6, 0(don't know) +sub irc_ip_get_version { + my $ip = shift || return; + + # If the address does not contain any ':', maybe it's IPv4 + return 4 if $ip !~ /:/ && irc_ip_is_ipv4($ip); + + # Is it IPv6 ? + return 6 if irc_ip_is_ipv6($ip); + + return; +} + +#------------------------------------------------------------------------------ +# Subroutine ip_is_ipv4 +# Purpose : Check if an IP address is version 4 +# Params : IP address +# Returns : 1 (yes) or 0 (no) +sub irc_ip_is_ipv4 { + my $ip = shift || return; + + # Check for invalid chars + if ($ip !~ /^[\d\.]+$/) { + $ERROR = "Invalid chars in IP $ip"; + $ERRNO = 107; + return; + } + + if ($ip =~ /^\./) { + $ERROR = "Invalid IP $ip - starts with a dot"; + $ERRNO = 103; + return; + } + + if ($ip =~ /\.$/) { + $ERROR = "Invalid IP $ip - ends with a dot"; + $ERRNO = 104; + return; + } + + # Single Numbers are considered to be IPv4 + return 1 if $ip =~ /^(\d+)$/ && $1 < 256; + + # Count quads + my $n = ($ip =~ tr/\./\./); + + # IPv4 must have from 1 to 4 quads + if ($n <= 0 || $n > 4) { + $ERROR = "Invalid IP address $ip"; + $ERRNO = 105; + return; + } + + # Check for empty quads + if ($ip =~ /\.\./) { + $ERROR = "Empty quad in IP address $ip"; + $ERRNO = 106; + return; + } + + for my $quad (split /\./, $ip) { + # Check for invalid quads + if ($quad < 0 || $quad >= 256) { + $ERROR = "Invalid quad in IP address $ip - $_"; + $ERRNO = 107; + return; + } + } + return 1; +} + +#------------------------------------------------------------------------------ +# Subroutine ip_is_ipv6 +# Purpose : Check if an IP address is version 6 +# Params : IP address +# Returns : 1 (yes) or 0 (no) +sub irc_ip_is_ipv6 { + my $ip = shift || return; + + # Count octets + my $n = ($ip =~ tr/:/:/); + return if ($n <= 0 || $n >= 8); + + # $k is a counter + my $k; + + for my $octet (split /:/, $ip) { + $k++; + + # Empty octet ? + next if $octet eq ''; + + # Normal v6 octet ? + next if $octet =~ /^[a-f\d]{1,4}$/i; + + # Last octet - is it IPv4 ? + if ($k == $n + 1) { + next if (ip_is_ipv4($octet)); + } + + $ERROR = "Invalid IP address $ip"; + $ERRNO = 108; + return; + } + + # Does the IP address start with : ? + if ($ip =~ m/^:[^:]/) { + $ERROR = "Invalid address $ip (starts with :)"; + $ERRNO = 109; + return; + } + + # Does the IP address finish with : ? + if ($ip =~ m/[^:]:$/) { + $ERROR = "Invalid address $ip (ends with :)"; + $ERRNO = 110; + return; + } + + # Does the IP address have more than one '::' pattern ? + if ($ip =~ s/:(?=:)//g > 1) { + $ERROR = "Invalid address $ip (More than one :: pattern)"; + $ERRNO = 111; + return; + } + + return 1; +} + +1; +__END__ + +=head1 NAME + +src::PoCiCommon - provides a set of common functions for the +infobot suite. Code originally from POE::Component::IRC::Common. + +=head1 SYNOPSIS + + use strict; + use warnings; + + use src::PoCiCommon qw( :ALL ); + + my $nickname = '^Lame|BOT[moo]'; + my $uppercase_nick = u_irc( $nickname ); + my $lowercase_nick = l_irc( $nickname ); + + my $mode_line = 'ov+b-i Bob sue stalin*!*@*'; + my $hashref = parse_mode_line( $mode_line ); + + my $banmask = 'stalin*'; + my $full_banmask = parse_ban_mask( $banmask ); + + if ( matches_mask( $full_banmask, 'stalin!joe@kremlin.ru' ) ) { + print "EEK!"; + } + + if ( has_color($message) ) { + print 'COLOR CODE ALERT!"; + } + + my $results_hashref = matches_mask_array( \@masks, \@items_to_match_against ); + + my $nick = parse_user( 'stalin!joe@kremlin.ru' ); + my ($nick, $user, $host) = parse_user( 'stalin!joe@kremlin.ru' ); + +=head1 DESCRIPTION + +src::PoCiCommon provides a set of common functions for the infobot suite. +Original code from POE::Component::IRC::Common. There are included functions +for uppercase and lowercase nicknames/channelnames and for parsing mode lines +and ban masks. + +=head1 CONSTANTS + +Use the following constants to add formatting and mIRC color codes to IRC +messages. + +Normal text: + + NORMAL + +Formatting: + + BOLD + UNDERLINE + REVERSE + ITALIC + FIXED + +Colors: + + WHITE + BLACK + DARK_BLUE + DARK_GREEN + RED + BROWN + PURPLE + ORANGE + YELLOW + LIGHT_GREEN + TEAL + CYAN + LIGHT_BLUE + MAGENTA + DARK_GREY + LIGHT_GREY + +Individual formatting codes can be cancelled with their corresponding constant, +but you can also cancel all of them at once with C. To cancel the effect +of previous color codes, you must use C. which of course has the side +effect of cancelling the effect of all previous formatting codes as well. + + $irc->yield('This word is ' . YELLOW . 'yellow' . NORMAL + . ' while this word is ' . BOLD . 'bold' . BOLD); + + $irc->yield(UNDERLINE . BOLD . 'This sentence is both underlined and bold.' + . NORMAL); + + + +=head1 FUNCTIONS + +=head2 C + +Takes one mandatory parameter, a string to convert to IRC uppercase, and one +optional parameter, the casemapping of the ircd ( which can be 'rfc1459', +'strict-rfc1459' or 'ascii'. Default is 'rfc1459' ). Returns the IRC uppercase +equivalent of the passed string. + +=head2 C + +Takes one mandatory parameter, a string to convert to IRC lowercase, and one +optional parameter, the casemapping of the ircd ( which can be 'rfc1459', +'strict-rfc1459' or 'ascii'. Default is 'rfc1459' ). Returns the IRC lowercase +equivalent of the passed string. + +=head2 C + +Takes a list representing an IRC mode line. Returns a hashref. If the modeline +couldn't be parsed the hashref will be empty. On success the following keys +will be available in the hashref: + + 'modes', an arrayref of normalised modes; + 'args', an arrayref of applicable arguments to the modes; + +Example: + + my $hashref = parse_mode_line( 'ov+b-i', 'Bob', 'sue', 'stalin*!*@*' ); + + # $hashref will be: + { + modes => [ '+o', '+v', '+b', '-i' ], + args => [ 'Bob', 'sue', 'stalin*!*@*' ], + } + +=head2 C + +Takes one parameter, a string representing an IRC ban mask. Returns a +normalised full banmask. + +Example: + + $fullbanmask = parse_ban_mask( 'stalin*' ); + + # $fullbanmask will be: 'stalin*!*@*'; + +=head2 C + +Takes two parameters, a string representing an IRC mask ( it'll be processed +with parse_ban_mask() to ensure that it is normalised ) and something to match +against the IRC mask, such as a nick!user@hostname string. Returns a true +value if they match, a false value otherwise. Optionally, one may pass the +casemapping (see L|/"u_irc">), as this function uses C +internally. + +=head2 C + +Takes two array references, the first being a list of strings representing +IRC masks, the second a list of somethings to test against the masks. Returns +an empty hashref if there are no matches. Otherwise, the keys will be the +masks matched, each value being an arrayref of the strings that matched it. +Optionally, one may pass the casemapping (see L|/"u_irc">), as +this function uses C internally. + +=head2 C + +Takes one parameter, a string representing a user in the form +nick!user@hostname. In a scalar context it returns just the nickname. +In a list context it returns a list consisting of the nick, user and hostname, +respectively. + +=head2 C + +Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC +color codes, 0 otherwise. Useful if you want your bot to kick users for +(ab)using colors. :) + +=head2 C + +Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC +formatting codes, 0 otherwise. + +=head2 C + +Takes one paramter, a string of IRC text. Returns the string stripped of all +IRC color codes. Due to the fact that both color and formatting codes can +be cancelled with the same character, this might strip more than you hoped for +if the string contains both color and formatting codes. Stripping both will +always do what you expect it to. + +=head2 C + +Takes one paramter, a string of IRC text. Returns the string stripped of all +IRC formatting codes. Due to the fact that both color and formatting codes can +be cancelled with the same character, this might strip more than you hoped for +if the string contains both color and formatting codes. Stripping both will +always do what you expect it to. + +=head2 C + +Try to guess the IP version of an IP address. + +Params: IP address +Returns: 4, 6, 0(unable to determine) + +C<$version = ip_get_version ($ip)> + +=head2 C + +Check if an IP address is of type 4. + +Params: IP address +Returns: 1 (yes) or 0 (no) + +C + +=head2 C + +Check if an IP address is of type 6. + +Params: IP address +Returns: 1 (yes) or 0 (no) + + ip_is_ipv6($ip) && print "$ip is IPv6"; + +=head1 AUTHOR + +Dan 'troubled' McGrath + +This whole module is shamelessly 'borrowed' from L +by Chris 'BinGOs' Williams + +=head1 SEE ALSO + +L + +L + +L + +=cut