$IRC::Toolkit::ISupport::VERSION
=
'0.092002'
;
our
@EXPORT
=
'parse_isupport'
;
my
$parse_simple_flags
=
sub
{
my
(
$val
) =
@_
;
+{
map
{;
$_
=> 1 }
split
''
, (
defined
$val
?
$val
:
''
) }
};
my
$parse
= +{
chanlimit
=>
sub
{
my
(
$val
) =
@_
;
my
$ref
= {};
for
my
$chunk
(
split
/,/,
$val
) {
my
(
$prefixed
,
$num
) =
split
/:/,
$chunk
;
for
my
$pfx
(
split
''
,
$prefixed
) {
$ref
->{
$pfx
} =
$num
}
}
$ref
},
chanmodes
=>
sub
{
my
(
$val
) =
@_
;
my
(
$list
,
$always
,
$whenset
,
$bool
) =
split
/,/,
$val
;
+{
list
=> array(
split
''
, (
defined
$list
?
$list
:
''
) ),
always
=> array(
split
''
, (
defined
$always
?
$always
:
''
) ),
whenset
=> array(
split
''
, (
defined
$whenset
?
$whenset
:
''
) ),
bool
=> array(
split
''
, (
defined
$bool
?
$bool
:
''
) ),
}
},
chantypes
=>
$parse_simple_flags
,
elist
=>
$parse_simple_flags
,
extban
=>
sub
{
my
(
$val
) =
@_
;
my
(
$prefix
,
$flags
) =
split
/,/,
$val
;
+{
prefix
=>
$prefix
,
flags
=> array(
split
''
, (
defined
$flags
?
$flags
:
''
) ),
}
},
maxlist
=>
sub
{
my
(
$val
) =
@_
;
my
$ref
= {};
for
my
$chunk
(
split
/,/,
$val
) {
my
(
$modes
,
$num
) =
split
/:/,
$chunk
;
my
@splitm
=
split
''
,
$modes
;
for
my
$mode
(
@splitm
) {
$ref
->{
$mode
} =
$num
}
}
$ref
},
prefix
=>
sub
{
my
(
$val
) =
@_
;
my
(
$modes
,
$prefixes
) =
$val
=~ /\(([^)]+)\)(.+)/;
return
+{}
unless
$modes
and
$prefixes
;
my
@modes
=
split
''
,
$modes
;
my
@pfxs
=
split
''
,
$prefixes
;
unless
(
@modes
==
@pfxs
) {
warn
"modes/prefixes do not appear to match: $modes $prefixes"
;
return
+{}
}
my
$ref
= +{};
for
my
$mode
(
@modes
) {
$ref
->{
$mode
} =
shift
@pfxs
}
$ref
},
statusmsg
=>
$parse_simple_flags
,
targmax
=>
sub
{
my
(
$val
) =
@_
;
my
$ref
= +{};
TARGTYPE:
for
my
$chunk
(
split
/,/,
$val
) {
my
(
$type
,
$lim
) =
split
/:/,
$chunk
, 2;
next
TARGTYPE
unless
defined
$lim
;
$ref
->{
lc
$type
} =
$lim
;
}
$ref
},
};
sub
_isupport_hash {
my
(
$obj
) =
@_
;
my
%cur
;
confess
"No object passed or no params to process"
unless
defined
$obj
and @{
$obj
->params };
my
%split
=
map
{;
my
(
$key
,
$val
) =
split
/=/,
$_
, 2;
(
lc
(
$key
), (
defined
$val
?
$val
:
'0 but true'
) )
} @{
$obj
->params }[1 .. ($
unless
(
keys
%split
) {
warn
"Appear to have been passed valid IRC, but not an ISUPPORT string"
;
return
+{}
}
for
my
$param
(
keys
%split
) {
if
(
defined
$parse
->{
$param
} &&
defined
$split
{
$param
}) {
$cur
{
$param
} =
$parse
->{
$param
}->(
$split
{
$param
})
}
else
{
$cur
{
$param
} =
$split
{
$param
}
}
}
\
%cur
}
sub
_isupport_hash_to_obj { IRC::Toolkit::ISupport::Obj->__new(
$_
[0]) }
sub
parse_isupport {
my
@items
=
map
{;
blessed
$_
?
$_
: ircmsg(
raw_line
=>
$_
)
}
@_
;
confess
'Expected a list of raw IRC lines or IRC::Message::Object instances'
unless
@items
;
my
%cur
;
ITEM:
for
my
$item
(
@items
) {
if
(
$item
->isa(
'IRC::Message::Object'
)) {
my
$piece
= _isupport_hash(
$item
);
@cur
{
keys
%$piece
} =
values
%$piece
;
next
ITEM
}
else
{
confess
"expected an IRC::Message::Object but got $item"
}
}
_isupport_hash_to_obj(\
%cur
);
}
{
package
IRC::Toolkit::_ISchanmodes;
sub
new {
bless
+{
@_
[1 ..
$#_
] },
$_
[0] }
sub
list {
$_
[0]->{list} }
sub
always {
$_
[0]->{always} }
sub
whenset {
$_
[0]->{whenset} }
sub
bool {
$_
[0]->{bool} }
sub
as_string {
my
(
$self
) =
@_
;
join
','
,
map
{;
join
''
,
@$_
}
$self
->list,
$self
->always,
$self
->whenset,
$self
->bool
}
}
{
package
IRC::Toolkit::_ISextban;
sub
new {
bless
+{
@_
[1 ..
$#_
] },
$_
[0] }
sub
prefix {
$_
[0]->{prefix} }
sub
flags {
$_
[0]->{flags} }
sub
as_string {
my
(
$self
) =
@_
;
join
','
,
$self
->prefix,
join
''
, @{
$self
->flags }
}
}
{
package
IRC::Toolkit::ISupport::Obj;
{
no
strict
'refs'
;
for
my
$acc
(
qw/
chanlimit
chantypes
elist
maxlist
prefix
statusmsg
targmax
/
) {
*{ __PACKAGE__ .
'::'
.
$acc
} =
sub
{
my
(
$ins
,
$val
) =
@_
;
return
(
$ins
->{
$acc
} || +{})
unless
defined
$val
;
$ins
->{
$acc
}->{
$val
}
};
}
}
sub
__new {
my
(
$cls
,
$self
) =
@_
;
confess
"Expected a HASH from _isupport_hash"
unless
ref
$self
eq
'HASH'
;
bless
$self
,
$cls
}
sub
chanmodes {
my
(
$self
) =
@_
;
return
unless
$self
->{chanmodes};
unless
(blessed
$self
->{chanmodes}) {
return
$self
->{chanmodes} =
IRC::Toolkit::_ISchanmodes->new(%{
$self
->{chanmodes}})
}
$self
->{chanmodes}
}
sub
extban {
my
(
$self
) =
@_
;
return
unless
$self
->{extban};
unless
(blessed
$self
->{extban}) {
return
$self
->{extban} =
IRC::Toolkit::_ISextban->new(%{
$self
->{extban}})
}
$self
->{extban}
}
our
$AUTOLOAD
;
sub
AUTOLOAD {
my
(
$self
) =
@_
;
my
$method
= (
split
/::/,
$AUTOLOAD
)[-1];
$self
->{
$method
}
}
sub
can {
my
(
$self
,
$method
) =
@_
;
if
(
my
$sub
=
$self
->SUPER::can(
$method
)) {
return
$sub
}
return
unless
exists
$self
->{
$method
};
sub
{
my
(
$this
) =
@_
;
if
(
my
$sub
=
$this
->SUPER::can(
$method
)) {
goto
$sub
}
$AUTOLOAD
=
$method
;
goto
&AUTOLOAD
}
}
sub
DESTROY {}
}
print
qq[<Gilded> "BREAKING: NH MAN HEARS ABOUT CLIMATE CHANGE, ]
,
qq[CLEARS FIVE HUNDRED ACRES FOR COCA PLANTATION"\n]
unless
caller
;
1;