Net/IRC3/Util.pm

package Net::IRC3::Util;
use strict;
use Exporter;
our @ISA = qw/Exporter/;
our @EXPORT_OK =
   qw(mk_msg parse_irc_msg split_prefix prefix_nick
      decode_ctcp filter_ctcp_text_attr prefix_user prefix_host);

=head1 NAME

Net::IRC3::Util - Common utilities that help with IRC protocol handling

=head1 SYNOPSIS

   use Net::IRC3 qw/parse_irc_msg mk_msg/;

   my $msgdata = mk_msg (undef, PRIVMSG 

=head1 FUNCTIONS

These are some utility functions that might come in handy when
handling the IRC protocol.

You can export these with eg.:

   use Net::IRC3 qw/parse_irc_msg/;

=over 4

=item B<parse_irc_msg ($ircline)>

This method parses the C<$ircline>, which is one line of the IRC protocol
without the trailing "\015\012".

It returns a hash which has the following entrys:

=over 4

=item prefix

The message prefix.

=item command

The IRC command.

=item params

The parameters to the IRC command in a array reference,
this includes the trailing parameter (the one after the ':' or
the 14th parameter).

=item trailing

This is set if there was a trailing parameter (the one after the ':' or
the 14th parameter).

=back

=cut

sub parse_irc_msg {
  my ($msg) = @_;

  my $cmd;
  my $pref;
  my $t;
  my @a;

  my $p = $msg =~ s/^(:([^ ]+)[ ])?([A-Za-z]+|\d{3})//;
  $pref = $2;
  $cmd = $3;

  my $i = 0;

  while ($msg =~ s/^[ ]([^ :\015\012\0][^ \015\012\0]*)//) {

    push @a, $1 if defined $1;
    if (++$i > 13) { last; }
  }

  if ($i == 14) {

    if ($msg =~ s/^[ ]:?([^\015\012\0]*)//) {
      $t = $1 if $1 ne "";
    }

  } else {

    if ($msg =~ s/^[ ]:([^\015\012\0]*)//) {
      $t = $1 if $1 ne "";
    }
  }

  push @a, $t if defined $t;

  my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };
  return $p ? $m : undef;
}

=item B<mk_msg ($prefix, $command, $trailing, @params)>

This function assembles a IRC message. The generated
message will look like (pseudo code!)

   :<prefix> <command> <params> :<trail>

Please refer to RFC 2812 how IRC messages normally look like.

The prefix and the trailing string will be omitted if they are C<undef>.

EXAMPLES:

   mk_msg (undef, "PRIVMSG", "you suck!", "magnus");
   # will return: "PRIVMSG magnus :you suck!\015\012"

   mk_msg (undef, "JOIN", undef, "#test");
   # will return: "JOIN #test\015\012"

=cut

sub mk_msg {
  my ($prefix, $command, $trail, @params) = @_;
  my $msg = "";

  $msg .= defined $prefix ? ":$prefix " : "";
  $msg .= "$command";

  # FIXME: params must be counted, and if > 13 they have to be
  # concationated with $trail
  map { $msg .= " $_" } @params;

  $msg .= defined $trail ? " :$trail" : "";
  $msg .= "\015\012";

  return $msg;
}


=item B<decode_ctcp_req ($line)>

=cut

sub decode_ctcp {
   my ($line) = @_;

   while ($line =~ /\G\001([^\001]*)\001/g) {
      my $req = $1;
   }

   $line =~ s/\001[^\001]*\001//g;

   return $line;
}

# implemented after the below CTCP spec, but
# doesnt seem to be used by anyone... so it's untested.
sub filter_ctcp_text_attr {
   my ($line, $cb) = @_;
   $cb ||= sub { '' };
   $line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
   $line =~ s/\006CA((?:I[0-9A-F]|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
   $line =~ s/\006C([FB])(I[0-9A-F]|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
   $line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
   return $line;
}

=item B<split_prefix ($prefix)>

This function splits an IRC user prefix as described by RFC 2817
into the three parts: nickname, user and host. Which will be
returned as a list with that order.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub split_prefix {
   my ($prfx) = @_;

   if (ref ($prfx) eq 'HASH') {
      $prfx = $prfx->{prefix};
   }

   $prfx =~ m/^\s*([^!]*)!([^@]*)@(.*?)\s*$/;
   return ($1, $2, $3);
}

=item B<prefix_nick ($prefix)>

A shortcut to extract the nickname from the C<$prefix>.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub prefix_nick {
   my ($prfx) = @_;
   return (split_prefix ($prfx))[0];
}

=item B<prefix_user ($prefix)>

A shortcut to extract the username from the C<$prefix>.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub prefix_user {
   my ($prfx) = @_;
   return (split_prefix ($prfx))[1];
}

=item B<prefix_host ($prefix)>

A shortcut to extract the hostname from the C<$prefix>.

C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.

=cut

sub prefix_host {
   my ($self, $prfx) = @_;
   return (split_prefix ($prfx))[2];
}

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex@ta-sa.org> >>

=head1 SEE ALSO

Internet Relay Chat Client To Client Protocol from February 2, 1997
http://www.invlogic.com/irc/ctcp.html

RFC 2812 - Internet Relay Chat: Client Protocol

=head1 COPYRIGHT & LICENSE

Copyright 2006 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
Revision:	1.6
Committed:	Tue Jul 18 11:12:09 2006 UTC (18 years, 4 months ago) by elmex
Branch:	MAIN
Changes since 1.5:	+22 -13 lines
Log Message:	hacked around for CTCP
#	Content
1	package Net::IRC3::Util;
2	use strict;
3	use Exporter;
4	our @ISA = qw/Exporter/;
5	our @EXPORT_OK =
6	qw(mk_msg parse_irc_msg split_prefix prefix_nick
7	decode_ctcp filter_ctcp_text_attr prefix_user prefix_host);
8
9	=head1 NAME
10
11	Net::IRC3::Util - Common utilities that help with IRC protocol handling
12
13	=head1 SYNOPSIS
14
15	use Net::IRC3 qw/parse_irc_msg mk_msg/;
16
17	my $msgdata = mk_msg (undef, PRIVMSG
18
19	=head1 FUNCTIONS
20
21	These are some utility functions that might come in handy when
22	handling the IRC protocol.
23
24	You can export these with eg.:
25
26	use Net::IRC3 qw/parse_irc_msg/;
27
28	=over 4
29
30	=item B<parse_irc_msg ($ircline)>
31
32	This method parses the C<$ircline>, which is one line of the IRC protocol
33	without the trailing "\015\012".
34
35	It returns a hash which has the following entrys:
36
37	=over 4
38
39	=item prefix
40
41	The message prefix.
42
43	=item command
44
45	The IRC command.
46
47	=item params
48
49	The parameters to the IRC command in a array reference,
50	this includes the trailing parameter (the one after the ':' or
51	the 14th parameter).
52
53	=item trailing
54
55	This is set if there was a trailing parameter (the one after the ':' or
56	the 14th parameter).
57
58	=back
59
60	=cut
61
62	sub parse_irc_msg {
63	my ($msg) = @_;
64
65	my $cmd;
66	my $pref;
67	my $t;
68	my @a;
69
70	my $p = $msg =~ s/^(:([^ ]+)[ ])?([A-Za-z]+\|\d{3})//;
71	$pref = $2;
72	$cmd = $3;
73
74	my $i = 0;
75
76	while ($msg =~ s/^[ ]([^ :\015\012\0][^ \015\012\0]*)//) {
77
78	push @a, $1 if defined $1;
79	if (++$i > 13) { last; }
80	}
81
82	if ($i == 14) {
83
84	if ($msg =~ s/^[ ]:?([^\015\012\0]*)//) {
85	$t = $1 if $1 ne "";
86	}
87
88	} else {
89
90	if ($msg =~ s/^[ ]:([^\015\012\0]*)//) {
91	$t = $1 if $1 ne "";
92	}
93	}
94
95	push @a, $t if defined $t;
96
97	my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };
98	return $p ? $m : undef;
99	}
100
101	=item B<mk_msg ($prefix, $command, $trailing, @params)>
102
103	This function assembles a IRC message. The generated
104	message will look like (pseudo code!)
105
106	:<prefix> <command> <params> :<trail>
107
108	Please refer to RFC 2812 how IRC messages normally look like.
109
110	The prefix and the trailing string will be omitted if they are C<undef>.
111
112	EXAMPLES:
113
114	mk_msg (undef, "PRIVMSG", "you suck!", "magnus");
115	# will return: "PRIVMSG magnus :you suck!\015\012"
116
117	mk_msg (undef, "JOIN", undef, "#test");
118	# will return: "JOIN #test\015\012"
119
120	=cut
121
122	sub mk_msg {
123	my ($prefix, $command, $trail, @params) = @_;
124	my $msg = "";
125
126	$msg .= defined $prefix ? ":$prefix " : "";
127	$msg .= "$command";
128
129	# FIXME: params must be counted, and if > 13 they have to be
130	# concationated with $trail
131	map { $msg .= " $_" } @params;
132
133	$msg .= defined $trail ? " :$trail" : "";
134	$msg .= "\015\012";
135
136	return $msg;
137	}
138
139
140	=item B<decode_ctcp_req ($line)>
141
142	=cut
143
144	sub decode_ctcp {
145	my ($line) = @_;
146
147	while ($line =~ /\G\001([^\001]*)\001/g) {
148	my $req = $1;
149	}
150
151	$line =~ s/\001[^\001]*\001//g;
152
153	return $line;
154	}
155
156	# implemented after the below CTCP spec, but
157	# doesnt seem to be used by anyone... so it's untested.
158	sub filter_ctcp_text_attr {
159	my ($line, $cb) = @_;
160	$cb \|\|= sub { '' };
161	$line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
162	$line =~ s/\006CA((?:I[0-9A-F]\|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
163	$line =~ s/\006C([FB])(I[0-9A-F]\|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
164	$line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
165	return $line;
166	}
167
168	=item B<split_prefix ($prefix)>
169
170	This function splits an IRC user prefix as described by RFC 2817
171	into the three parts: nickname, user and host. Which will be
172	returned as a list with that order.
173
174	C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
175
176	=cut
177
178	sub split_prefix {
179	my ($prfx) = @_;
180
181	if (ref ($prfx) eq 'HASH') {
182	$prfx = $prfx->{prefix};
183	}
184
185	$prfx =~ m/^\s([^!])!([^@])@(.?)\s*$/;
186	return ($1, $2, $3);
187	}
188
189	=item B<prefix_nick ($prefix)>
190
191	A shortcut to extract the nickname from the C<$prefix>.
192
193	C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
194
195	=cut
196
197	sub prefix_nick {
198	my ($prfx) = @_;
199	return (split_prefix ($prfx))[0];
200	}
201
202	=item B<prefix_user ($prefix)>
203
204	A shortcut to extract the username from the C<$prefix>.
205
206	C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
207
208	=cut
209
210	sub prefix_user {
211	my ($prfx) = @_;
212	return (split_prefix ($prfx))[1];
213	}
214
215	=item B<prefix_host ($prefix)>
216
217	A shortcut to extract the hostname from the C<$prefix>.
218
219	C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
220
221	=cut
222
223	sub prefix_host {
224	my ($self, $prfx) = @_;
225	return (split_prefix ($prfx))[2];
226	}
227
228	=back
229
230	=head1 AUTHOR
231
232	Robin Redeker, C<< <elmex@ta-sa.org> >>
233
234	=head1 SEE ALSO
235
236	Internet Relay Chat Client To Client Protocol from February 2, 1997
237	http://www.invlogic.com/irc/ctcp.html
238
239	RFC 2812 - Internet Relay Chat: Client Protocol
240
241	=head1 COPYRIGHT & LICENSE
242
243	Copyright 2006 Robin Redeker, all rights reserved.
244
245	This program is free software; you can redistribute it and/or modify it
246	under the same terms as Perl itself.
247
248	=cut
249
250	1;