--- /dev/null
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+\f
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+\f
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+\f
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+\f
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+\f
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
--- /dev/null
+# Date::Parse $Id: //depot/TimeDate/lib/Date/Parse.pm#22 $
+#
+# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+# software; you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+
+package Date::Parse;
+
+require 5.000;
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+use Time::Local;
+use Carp;
+use Time::Zone;
+use Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&strtotime &str2time &strptime);
+
+$VERSION = "2.27";
+
+my %month = (
+ january => 0,
+ february => 1,
+ march => 2,
+ april => 3,
+ may => 4,
+ june => 5,
+ july => 6,
+ august => 7,
+ september => 8,
+ sept => 8,
+ october => 9,
+ november => 10,
+ december => 11,
+ );
+
+my %day = (
+ sunday => 0,
+ monday => 1,
+ tuesday => 2,
+ tues => 2,
+ wednesday => 3,
+ wednes => 3,
+ thursday => 4,
+ thur => 4,
+ thurs => 4,
+ friday => 5,
+ saturday => 6,
+ );
+
+my @suf = (qw(th st nd rd th th th th th th)) x 3;
+@suf[11,12,13] = qw(th th th);
+
+#Abbreviations
+
+map { $month{substr($_,0,3)} = $month{$_} } keys %month;
+map { $day{substr($_,0,3)} = $day{$_} } keys %day;
+
+my $strptime = <<'ESQ';
+ my %month = map { lc $_ } %$mon_ref;
+ my $daypat = join("|", map { lc $_ } reverse sort keys %$day_ref);
+ my $monpat = join("|", reverse sort keys %month);
+ my $sufpat = join("|", reverse sort map { lc $_ } @$suf_ref);
+
+ my %ampm = (
+ 'a' => 0, # AM
+ 'p' => 12, # PM
+ );
+
+ my($AM, $PM) = (0,12);
+
+sub {
+
+ my $dtstr = lc shift;
+ my $merid = 24;
+
+ my($year,$month,$day,$hh,$mm,$ss,$zone,$dst,$frac);
+
+ $zone = tz_offset(shift) if @_;
+
+ 1 while $dtstr =~ s#\([^\(\)]*\)# #o;
+
+ $dtstr =~ s#(\A|\n|\Z)# #sog;
+
+ # ignore day names
+ $dtstr =~ s#([\d\w\s])[\.\,]\s#$1 #sog;
+ $dtstr =~ s/,/ /g;
+ $dtstr =~ s#($daypat)\s*(den\s)?# #o;
+ # Time: 12:00 or 12:00:00 with optional am/pm
+
+ return unless $dtstr =~ /\S/;
+
+ if ($dtstr =~ s/\s(\d{4})([-:]?)(\d\d?)\2(\d\d?)(?:[Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\6(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) {
+ ($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$3-1,$4,$5,$7,$8,$9);
+ }
+
+ unless (defined $hh) {
+ if ($dtstr =~ s#[:\s](\d\d?):(\d\d?)(:(\d\d?)(?:\.\d+)?)?\s*(?:([ap])\.?m?\.?)?\s# #o) {
+ ($hh,$mm,$ss) = ($1,$2,$4 || 0);
+ $merid = $ampm{$5} if $5;
+ }
+
+ # Time: 12 am
+
+ elsif ($dtstr =~ s#\s(\d\d?)\s*([ap])\.?m?\.?\s# #o) {
+ ($hh,$mm,$ss) = ($1,0,0);
+ $merid = $ampm{$2};
+ }
+ }
+
+ if (defined $hh and $hh <= 12 and $dtstr =~ s# ([ap])\.?m?\.?\s# #o) {
+ $merid = $ampm{$1};
+ }
+
+
+ unless (defined $year) {
+ # Date: 12-June-96 (using - . or /)
+
+ if ($dtstr =~ s#\s(\d\d?)([\-\./])($monpat)(\2(\d\d+))?\s# #o) {
+ ($month,$day) = ($month{$3},$1);
+ $year = $5 if $5;
+ }
+
+ # Date: 12-12-96 (using '-', '.' or '/' )
+
+ elsif ($dtstr =~ s#\s(\d+)([\-\./])(\d\d?)(\2(\d+))?\s# #o) {
+ ($month,$day) = ($1 - 1,$3);
+
+ if ($5) {
+ $year = $5;
+ # Possible match for 1995-01-24 (short mainframe date format);
+ ($year,$month,$day) = ($1, $3 - 1, $5) if $month > 12;
+ return if length($year) > 2 and $year < 1901;
+ }
+ }
+ elsif ($dtstr =~ s#\s(\d+)\s*($sufpat)?\s*($monpat)# #o) {
+ ($month,$day) = ($month{$3},$1);
+ }
+ elsif ($dtstr =~ s#($monpat)\s*(\d+)\s*($sufpat)?\s# #o) {
+ ($month,$day) = ($month{$1},$2);
+ }
+
+ # Date: 961212
+
+ elsif ($dtstr =~ s#\s(\d\d)(\d\d)(\d\d)\s# #o) {
+ ($year,$month,$day) = ($1,$2-1,$3);
+ }
+
+ $year = $1 if !defined($year) and $dtstr =~ s#\s(\d{2}(\d{2})?)[\s\.,]# #o;
+
+ }
+
+ # Zone
+
+ $dst = 1 if $dtstr =~ s#\bdst\b##o;
+
+ if ($dtstr =~ s#\s"?([a-z]{3,4})(dst|\d+[a-z]*|_[a-z]+)?"?\s# #o) {
+ $dst = 1 if $2 and $2 eq 'dst';
+ $zone = tz_offset($1);
+ return unless defined $zone;
+ }
+ elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?):?(\d\d)?(00)?\s# #o) {
+ my $m = defined($4) ? "$2$4" : 0;
+ my $h = "$2$3";
+ $zone = defined($1) ? tz_offset($1) : 0;
+ return unless defined $zone;
+ $zone += 60 * ($m + (60 * $h));
+ }
+
+ if ($dtstr =~ /\S/) {
+ # now for some dumb dates
+ if ($dtstr =~ s/^\s*(ut?|z)\s*$//) {
+ $zone = 0;
+ }
+ elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?)(\d\d)?(00)?\s# #o) {
+ my $m = defined($4) ? "$2$4" : 0;
+ my $h = "$2$3";
+ $zone = defined($1) ? tz_offset($1) : 0;
+ return unless defined $zone;
+ $zone += 60 * ($m + (60 * $h));
+ }
+
+ return if $dtstr =~ /\S/o;
+ }
+
+ if (defined $hh) {
+ if ($hh == 12) {
+ $hh = 0 if $merid == $AM;
+ }
+ elsif ($merid == $PM) {
+ $hh += 12;
+ }
+ }
+
+ $year -= 1900 if defined $year && $year > 1900;
+
+ $zone += 3600 if defined $zone && $dst;
+ $ss += "0.$frac" if $frac;
+
+ return ($ss,$mm,$hh,$day,$month,$year,$zone);
+}
+ESQ
+
+use vars qw($day_ref $mon_ref $suf_ref $obj);
+
+sub gen_parser
+{
+ local($day_ref,$mon_ref,$suf_ref,$obj) = @_;
+
+ if($obj)
+ {
+ my $obj_strptime = $strptime;
+ substr($obj_strptime,index($strptime,"sub")+6,0) = <<'ESQ';
+ shift; # package
+ESQ
+ my $sub = eval "$obj_strptime" or die $@;
+ return $sub;
+ }
+
+ eval "$strptime" or die $@;
+
+}
+
+*strptime = gen_parser(\%day,\%month,\@suf);
+
+sub str2time
+{
+ my @t = strptime(@_);
+
+ return undef
+ unless @t;
+
+ my($ss,$mm,$hh,$day,$month,$year,$zone) = @t;
+ my @lt = localtime(time);
+
+ $hh ||= 0;
+ $mm ||= 0;
+ $ss ||= 0;
+
+ my $frac = $ss - int($ss);
+ $ss = int $ss;
+
+ $month = $lt[4]
+ unless(defined $month);
+
+ $day = $lt[3]
+ unless(defined $day);
+
+ $year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5]
+ unless(defined $year);
+
+ return undef
+ unless($month <= 11 && $day >= 1 && $day <= 31
+ && $hh <= 23 && $mm <= 59 && $ss <= 59);
+
+ my $result;
+
+ if (defined $zone) {
+ $result = eval {
+ local $SIG{__DIE__} = sub {}; # Ick!
+ timegm($ss,$mm,$hh,$day,$month,$year);
+ };
+ return undef
+ if !defined $result
+ or $result == -1
+ && join("",$ss,$mm,$hh,$day,$month,$year)
+ ne "595923311169";
+ $result -= $zone;
+ }
+ else {
+ $result = eval {
+ local $SIG{__DIE__} = sub {}; # Ick!
+ timelocal($ss,$mm,$hh,$day,$month,$year);
+ };
+ return undef
+ if !defined $result
+ or $result == -1
+ && join("",$ss,$mm,$hh,$day,$month,$year)
+ ne join("",(localtime(-1))[0..5]);
+ }
+
+ return $result + $frac;
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Date::Parse - Parse date strings into time values
+
+=head1 SYNOPSIS
+
+ use Date::Parse;
+
+ $time = str2time($date);
+
+ ($ss,$mm,$hh,$day,$month,$year,$zone) = strptime($date);
+
+=head1 DESCRIPTION
+
+C<Date::Parse> provides two routines for parsing date strings into time values.
+
+=over 4
+
+=item str2time(DATE [, ZONE])
+
+C<str2time> parses C<DATE> and returns a unix time value, or undef upon failure.
+C<ZONE>, if given, specifies the timezone to assume when parsing if the
+date string does not specify a timezome.
+
+=item strptime(DATE [, ZONE])
+
+C<strptime> takes the same arguments as str2time but returns an array of
+values C<($ss,$mm,$hh,$day,$month,$year,$zone)>. Elements are only defined
+if they could be extracted from the date string. The C<$zone> element is
+the timezone offset in seconds from GMT. An empty array is returned upon
+failure.
+
+=head1 MULTI-LANGUAGE SUPPORT
+
+Date::Parse is capable of parsing dates in several languages, these are
+English, French, German and Italian.
+
+ $lang = Date::Language->new('German');
+ $lang->str2time("25 Jun 1996 21:09:55 +0100");
+
+=head1 EXAMPLE DATES
+
+Below is a sample list of dates that are known to be parsable with Date::Parse
+
+ 1995:01:24T09:08:17.1823213 ISO-8601
+ 1995-01-24T09:08:17.1823213
+ Wed, 16 Jun 94 07:29:35 CST Comma and day name are optional
+ Thu, 13 Oct 94 10:13:13 -0700
+ Wed, 9 Nov 1994 09:50:32 -0500 (EST) Text in ()'s will be ignored.
+ 21 dec 17:05 Will be parsed in the current time zone
+ 21-dec 17:05
+ 21/dec 17:05
+ 21/dec/93 17:05
+ 1999 10:02:18 "GMT"
+ 16 Nov 94 22:28:20 PST
+
+=head1 LIMITATION
+
+Date::Parse uses Time::Local internally, so is limited to only parsing dates
+which result in valid values for Time::Local::timelocal
+
+=head1 BUGS
+
+When both the month and the date are specified in the date as numbers
+they are always parsed assuming that the month number comes before the
+date. This is the usual format used in American dates.
+
+The reason why it is like this and not dynamic is that it must be
+deterministic. Several people have suggested using the current locale,
+but this will not work as the date being parsed may not be in the format
+of the current locale.
+
+My plans to address this, which will be in a future release, is to allow
+the programmer to state what order they want these values parsed in.
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+# $Id: //depot/TimeDate/lib/Date/Parse.pm#22 $
+
--- /dev/null
+package Digest::SHA::PurePerl;
+
+require 5.003000;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+use integer;
+use FileHandle;
+
+$VERSION = '5.45';
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = (); # see "SHA and HMAC-SHA functions" below
+
+# If possible, inherit from Digest::base (which depends on MIME::Base64)
+
+*addfile = \&_Addfile;
+
+eval {
+ require MIME::Base64;
+ require Digest::base;
+ push(@ISA, 'Digest::base');
+};
+if ($@) {
+ *hexdigest = \&_Hexdigest;
+ *b64digest = \&_B64digest;
+}
+
+# ref. src/sha.c and sha/sha64bit.c from Digest::SHA
+
+my $MAX32 = 0xffffffff;
+my $TWO32 = 4294967296;
+
+my $uses64bit = (((1 << 16) << 16) << 16) << 15;
+
+
+my @H01 = ( # SHA-1 initial hash value
+ 0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476,
+ 0xc3d2e1f0
+);
+
+my @H0224 = ( # SHA-224 initial hash value
+ 0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,
+ 0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4
+);
+
+my @H0256 = ( # SHA-256 initial hash value
+ 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,
+ 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19
+);
+
+my(@H0384, @H0512); # filled in later if $uses64bit
+
+# Routines with a "_c_" prefix return Perl code-fragments which are
+# eval'ed at initialization. This technique emulates the behavior
+# of the C preprocessor, allowing the optimized transform code from
+# Digest::SHA to be more easily translated into Perl.
+
+sub _c_SL32 { # code to shift $x left by $n bits
+ my($x, $n) = @_;
+ "($x << $n)"; # even works for 64-bit integers
+ # since the upper 32 bits are
+ # eventually discarded in _digcpy
+}
+
+sub _c_SR32 { # code to shift $x right by $n bits
+ my($x, $n) = @_;
+ my $mask = (1 << (32 - $n)) - 1;
+ "(($x >> $n) & $mask)"; # "use integer" does arithmetic
+ # shift, so clear upper bits
+}
+
+sub _c_Ch { my($x, $y, $z) = @_; "($z ^ ($x & ($y ^ $z)))" }
+sub _c_Pa { my($x, $y, $z) = @_; "($x ^ $y ^ $z)" }
+sub _c_Ma { my($x, $y, $z) = @_; "(($x & $y) | ($z & ($x | $y)))" }
+
+sub _c_ROTR { # code to rotate $x right by $n bits
+ my($x, $n) = @_;
+ "(" . _c_SR32($x, $n) . " | " . _c_SL32($x, 32 - $n) . ")";
+}
+
+sub _c_ROTL { # code to rotate $x left by $n bits
+ my($x, $n) = @_;
+ "(" . _c_SL32($x, $n) . " | " . _c_SR32($x, 32 - $n) . ")";
+}
+
+sub _c_SIGMA0 { # ref. NIST SHA standard
+ my($x) = @_;
+ "(" . _c_ROTR($x, 2) . " ^ " . _c_ROTR($x, 13) . " ^ " .
+ _c_ROTR($x, 22) . ")";
+}
+
+sub _c_SIGMA1 {
+ my($x) = @_;
+ "(" . _c_ROTR($x, 6) . " ^ " . _c_ROTR($x, 11) . " ^ " .
+ _c_ROTR($x, 25) . ")";
+}
+
+sub _c_sigma0 {
+ my($x) = @_;
+ "(" . _c_ROTR($x, 7) . " ^ " . _c_ROTR($x, 18) . " ^ " .
+ _c_SR32($x, 3) . ")";
+}
+
+sub _c_sigma1 {
+ my($x) = @_;
+ "(" . _c_ROTR($x, 17) . " ^ " . _c_ROTR($x, 19) . " ^ " .
+ _c_SR32($x, 10) . ")";
+}
+
+sub _c_M1Ch { # ref. Digest::SHA sha.c (sha1 routine)
+ my($a, $b, $c, $d, $e, $k, $w) = @_;
+ "$e += " . _c_ROTL($a, 5) . " + " . _c_Ch($b, $c, $d) .
+ " + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
+}
+
+sub _c_M1Pa {
+ my($a, $b, $c, $d, $e, $k, $w) = @_;
+ "$e += " . _c_ROTL($a, 5) . " + " . _c_Pa($b, $c, $d) .
+ " + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
+}
+
+sub _c_M1Ma {
+ my($a, $b, $c, $d, $e, $k, $w) = @_;
+ "$e += " . _c_ROTL($a, 5) . " + " . _c_Ma($b, $c, $d) .
+ " + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
+}
+
+sub _c_M11Ch { my($k, $w) = @_; _c_M1Ch('$a', '$b', '$c', '$d', '$e', $k, $w) }
+sub _c_M11Pa { my($k, $w) = @_; _c_M1Pa('$a', '$b', '$c', '$d', '$e', $k, $w) }
+sub _c_M11Ma { my($k, $w) = @_; _c_M1Ma('$a', '$b', '$c', '$d', '$e', $k, $w) }
+sub _c_M12Ch { my($k, $w) = @_; _c_M1Ch('$e', '$a', '$b', '$c', '$d', $k, $w) }
+sub _c_M12Pa { my($k, $w) = @_; _c_M1Pa('$e', '$a', '$b', '$c', '$d', $k, $w) }
+sub _c_M12Ma { my($k, $w) = @_; _c_M1Ma('$e', '$a', '$b', '$c', '$d', $k, $w) }
+sub _c_M13Ch { my($k, $w) = @_; _c_M1Ch('$d', '$e', '$a', '$b', '$c', $k, $w) }
+sub _c_M13Pa { my($k, $w) = @_; _c_M1Pa('$d', '$e', '$a', '$b', '$c', $k, $w) }
+sub _c_M13Ma { my($k, $w) = @_; _c_M1Ma('$d', '$e', '$a', '$b', '$c', $k, $w) }
+sub _c_M14Ch { my($k, $w) = @_; _c_M1Ch('$c', '$d', '$e', '$a', '$b', $k, $w) }
+sub _c_M14Pa { my($k, $w) = @_; _c_M1Pa('$c', '$d', '$e', '$a', '$b', $k, $w) }
+sub _c_M14Ma { my($k, $w) = @_; _c_M1Ma('$c', '$d', '$e', '$a', '$b', $k, $w) }
+sub _c_M15Ch { my($k, $w) = @_; _c_M1Ch('$b', '$c', '$d', '$e', '$a', $k, $w) }
+sub _c_M15Pa { my($k, $w) = @_; _c_M1Pa('$b', '$c', '$d', '$e', '$a', $k, $w) }
+sub _c_M15Ma { my($k, $w) = @_; _c_M1Ma('$b', '$c', '$d', '$e', '$a', $k, $w) }
+
+sub _c_W11 { my($s) = @_; '$W[' . (($s + 0) & 0xf) . ']' }
+sub _c_W12 { my($s) = @_; '$W[' . (($s + 13) & 0xf) . ']' }
+sub _c_W13 { my($s) = @_; '$W[' . (($s + 8) & 0xf) . ']' }
+sub _c_W14 { my($s) = @_; '$W[' . (($s + 2) & 0xf) . ']' }
+
+sub _c_A1 {
+ my($s) = @_;
+ my $tmp = _c_W11($s) . " ^ " . _c_W12($s) . " ^ " .
+ _c_W13($s) . " ^ " . _c_W14($s);
+ "((\$tmp = $tmp), (" . _c_W11($s) . " = " . _c_ROTL('$tmp', 1) . "))";
+}
+
+# The following code emulates the "sha1" routine from Digest::SHA sha.c
+
+my $sha1_code = '
+
+my($K1, $K2, $K3, $K4) = ( # SHA-1 constants
+ 0x5a827999, 0x6ed9eba1, 0x8f1bbcdc, 0xca62c1d6
+);
+
+sub _sha1 {
+ my($self, $block) = @_;
+ my(@W, $a, $b, $c, $d, $e, $tmp);
+
+ @W = unpack("N16", $block);
+ ($a, $b, $c, $d, $e) = @{$self->{H}};
+' .
+ _c_M11Ch('$K1', '$W[ 0]' ) . _c_M12Ch('$K1', '$W[ 1]' ) .
+ _c_M13Ch('$K1', '$W[ 2]' ) . _c_M14Ch('$K1', '$W[ 3]' ) .
+ _c_M15Ch('$K1', '$W[ 4]' ) . _c_M11Ch('$K1', '$W[ 5]' ) .
+ _c_M12Ch('$K1', '$W[ 6]' ) . _c_M13Ch('$K1', '$W[ 7]' ) .
+ _c_M14Ch('$K1', '$W[ 8]' ) . _c_M15Ch('$K1', '$W[ 9]' ) .
+ _c_M11Ch('$K1', '$W[10]' ) . _c_M12Ch('$K1', '$W[11]' ) .
+ _c_M13Ch('$K1', '$W[12]' ) . _c_M14Ch('$K1', '$W[13]' ) .
+ _c_M15Ch('$K1', '$W[14]' ) . _c_M11Ch('$K1', '$W[15]' ) .
+ _c_M12Ch('$K1', _c_A1( 0) ) . _c_M13Ch('$K1', _c_A1( 1) ) .
+ _c_M14Ch('$K1', _c_A1( 2) ) . _c_M15Ch('$K1', _c_A1( 3) ) .
+ _c_M11Pa('$K2', _c_A1( 4) ) . _c_M12Pa('$K2', _c_A1( 5) ) .
+ _c_M13Pa('$K2', _c_A1( 6) ) . _c_M14Pa('$K2', _c_A1( 7) ) .
+ _c_M15Pa('$K2', _c_A1( 8) ) . _c_M11Pa('$K2', _c_A1( 9) ) .
+ _c_M12Pa('$K2', _c_A1(10) ) . _c_M13Pa('$K2', _c_A1(11) ) .
+ _c_M14Pa('$K2', _c_A1(12) ) . _c_M15Pa('$K2', _c_A1(13) ) .
+ _c_M11Pa('$K2', _c_A1(14) ) . _c_M12Pa('$K2', _c_A1(15) ) .
+ _c_M13Pa('$K2', _c_A1( 0) ) . _c_M14Pa('$K2', _c_A1( 1) ) .
+ _c_M15Pa('$K2', _c_A1( 2) ) . _c_M11Pa('$K2', _c_A1( 3) ) .
+ _c_M12Pa('$K2', _c_A1( 4) ) . _c_M13Pa('$K2', _c_A1( 5) ) .
+ _c_M14Pa('$K2', _c_A1( 6) ) . _c_M15Pa('$K2', _c_A1( 7) ) .
+ _c_M11Ma('$K3', _c_A1( 8) ) . _c_M12Ma('$K3', _c_A1( 9) ) .
+ _c_M13Ma('$K3', _c_A1(10) ) . _c_M14Ma('$K3', _c_A1(11) ) .
+ _c_M15Ma('$K3', _c_A1(12) ) . _c_M11Ma('$K3', _c_A1(13) ) .
+ _c_M12Ma('$K3', _c_A1(14) ) . _c_M13Ma('$K3', _c_A1(15) ) .
+ _c_M14Ma('$K3', _c_A1( 0) ) . _c_M15Ma('$K3', _c_A1( 1) ) .
+ _c_M11Ma('$K3', _c_A1( 2) ) . _c_M12Ma('$K3', _c_A1( 3) ) .
+ _c_M13Ma('$K3', _c_A1( 4) ) . _c_M14Ma('$K3', _c_A1( 5) ) .
+ _c_M15Ma('$K3', _c_A1( 6) ) . _c_M11Ma('$K3', _c_A1( 7) ) .
+ _c_M12Ma('$K3', _c_A1( 8) ) . _c_M13Ma('$K3', _c_A1( 9) ) .
+ _c_M14Ma('$K3', _c_A1(10) ) . _c_M15Ma('$K3', _c_A1(11) ) .
+ _c_M11Pa('$K4', _c_A1(12) ) . _c_M12Pa('$K4', _c_A1(13) ) .
+ _c_M13Pa('$K4', _c_A1(14) ) . _c_M14Pa('$K4', _c_A1(15) ) .
+ _c_M15Pa('$K4', _c_A1( 0) ) . _c_M11Pa('$K4', _c_A1( 1) ) .
+ _c_M12Pa('$K4', _c_A1( 2) ) . _c_M13Pa('$K4', _c_A1( 3) ) .
+ _c_M14Pa('$K4', _c_A1( 4) ) . _c_M15Pa('$K4', _c_A1( 5) ) .
+ _c_M11Pa('$K4', _c_A1( 6) ) . _c_M12Pa('$K4', _c_A1( 7) ) .
+ _c_M13Pa('$K4', _c_A1( 8) ) . _c_M14Pa('$K4', _c_A1( 9) ) .
+ _c_M15Pa('$K4', _c_A1(10) ) . _c_M11Pa('$K4', _c_A1(11) ) .
+ _c_M12Pa('$K4', _c_A1(12) ) . _c_M13Pa('$K4', _c_A1(13) ) .
+ _c_M14Pa('$K4', _c_A1(14) ) . _c_M15Pa('$K4', _c_A1(15) ) .
+
+' $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
+ $self->{H}->[3] += $d; $self->{H}->[4] += $e;
+}
+';
+
+eval($sha1_code);
+
+sub _c_M2 { # ref. Digest::SHA sha.c (sha256 routine)
+ my($a, $b, $c, $d, $e, $f, $g, $h, $w) = @_;
+ "\$T1 = $h + " . _c_SIGMA1($e) . " + " . _c_Ch($e, $f, $g) .
+ " + \$K256[\$i++] + $w; $h = \$T1 + " . _c_SIGMA0($a) .
+ " + " . _c_Ma($a, $b, $c) . "; $d += \$T1;\n";
+}
+
+sub _c_M21 { _c_M2('$a', '$b', '$c', '$d', '$e', '$f', '$g', '$h', $_[0]) }
+sub _c_M22 { _c_M2('$h', '$a', '$b', '$c', '$d', '$e', '$f', '$g', $_[0]) }
+sub _c_M23 { _c_M2('$g', '$h', '$a', '$b', '$c', '$d', '$e', '$f', $_[0]) }
+sub _c_M24 { _c_M2('$f', '$g', '$h', '$a', '$b', '$c', '$d', '$e', $_[0]) }
+sub _c_M25 { _c_M2('$e', '$f', '$g', '$h', '$a', '$b', '$c', '$d', $_[0]) }
+sub _c_M26 { _c_M2('$d', '$e', '$f', '$g', '$h', '$a', '$b', '$c', $_[0]) }
+sub _c_M27 { _c_M2('$c', '$d', '$e', '$f', '$g', '$h', '$a', '$b', $_[0]) }
+sub _c_M28 { _c_M2('$b', '$c', '$d', '$e', '$f', '$g', '$h', '$a', $_[0]) }
+
+sub _c_W21 { my($s) = @_; '$W[' . (($s + 0) & 0xf) . ']' }
+sub _c_W22 { my($s) = @_; '$W[' . (($s + 14) & 0xf) . ']' }
+sub _c_W23 { my($s) = @_; '$W[' . (($s + 9) & 0xf) . ']' }
+sub _c_W24 { my($s) = @_; '$W[' . (($s + 1) & 0xf) . ']' }
+
+sub _c_A2 {
+ my($s) = @_;
+ "(" . _c_W21($s) . " += " . _c_sigma1(_c_W22($s)) . " + " .
+ _c_W23($s) . " + " . _c_sigma0(_c_W24($s)) . ")";
+}
+
+# The following code emulates the "sha256" routine from Digest::SHA sha.c
+
+my $sha256_code = '
+
+my @K256 = ( # SHA-224/256 constants
+ 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,
+ 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
+ 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,
+ 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
+ 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,
+ 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
+ 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,
+ 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
+ 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,
+ 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
+ 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,
+ 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
+ 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,
+ 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
+ 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,
+ 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
+);
+
+sub _sha256 {
+ my($self, $block) = @_;
+ my(@W, $a, $b, $c, $d, $e, $f, $g, $h, $i, $T1);
+
+ @W = unpack("N16", $block);
+ ($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
+' .
+ _c_M21('$W[ 0]' ) . _c_M22('$W[ 1]' ) . _c_M23('$W[ 2]' ) .
+ _c_M24('$W[ 3]' ) . _c_M25('$W[ 4]' ) . _c_M26('$W[ 5]' ) .
+ _c_M27('$W[ 6]' ) . _c_M28('$W[ 7]' ) . _c_M21('$W[ 8]' ) .
+ _c_M22('$W[ 9]' ) . _c_M23('$W[10]' ) . _c_M24('$W[11]' ) .
+ _c_M25('$W[12]' ) . _c_M26('$W[13]' ) . _c_M27('$W[14]' ) .
+ _c_M28('$W[15]' ) .
+ _c_M21(_c_A2( 0)) . _c_M22(_c_A2( 1)) . _c_M23(_c_A2( 2)) .
+ _c_M24(_c_A2( 3)) . _c_M25(_c_A2( 4)) . _c_M26(_c_A2( 5)) .
+ _c_M27(_c_A2( 6)) . _c_M28(_c_A2( 7)) . _c_M21(_c_A2( 8)) .
+ _c_M22(_c_A2( 9)) . _c_M23(_c_A2(10)) . _c_M24(_c_A2(11)) .
+ _c_M25(_c_A2(12)) . _c_M26(_c_A2(13)) . _c_M27(_c_A2(14)) .
+ _c_M28(_c_A2(15)) . _c_M21(_c_A2( 0)) . _c_M22(_c_A2( 1)) .
+ _c_M23(_c_A2( 2)) . _c_M24(_c_A2( 3)) . _c_M25(_c_A2( 4)) .
+ _c_M26(_c_A2( 5)) . _c_M27(_c_A2( 6)) . _c_M28(_c_A2( 7)) .
+ _c_M21(_c_A2( 8)) . _c_M22(_c_A2( 9)) . _c_M23(_c_A2(10)) .
+ _c_M24(_c_A2(11)) . _c_M25(_c_A2(12)) . _c_M26(_c_A2(13)) .
+ _c_M27(_c_A2(14)) . _c_M28(_c_A2(15)) . _c_M21(_c_A2( 0)) .
+ _c_M22(_c_A2( 1)) . _c_M23(_c_A2( 2)) . _c_M24(_c_A2( 3)) .
+ _c_M25(_c_A2( 4)) . _c_M26(_c_A2( 5)) . _c_M27(_c_A2( 6)) .
+ _c_M28(_c_A2( 7)) . _c_M21(_c_A2( 8)) . _c_M22(_c_A2( 9)) .
+ _c_M23(_c_A2(10)) . _c_M24(_c_A2(11)) . _c_M25(_c_A2(12)) .
+ _c_M26(_c_A2(13)) . _c_M27(_c_A2(14)) . _c_M28(_c_A2(15)) .
+
+' $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
+ $self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
+ $self->{H}->[6] += $g; $self->{H}->[7] += $h;
+}
+';
+
+eval($sha256_code);
+
+sub _sha512_placeholder { return }
+my $sha512 = \&_sha512_placeholder;
+
+my $_64bit_code = '
+
+BEGIN { $^W = 0 } # suppress warnings triggered by 64-bit constants
+
+my @K512 = (
+ 0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f,
+ 0xe9b5dba58189dbbc, 0x3956c25bf348b538, 0x59f111f1b605d019,
+ 0x923f82a4af194f9b, 0xab1c5ed5da6d8118, 0xd807aa98a3030242,
+ 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2,
+ 0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235,
+ 0xc19bf174cf692694, 0xe49b69c19ef14ad2, 0xefbe4786384f25e3,
+ 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65, 0x2de92c6f592b0275,
+ 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
+ 0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f,
+ 0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725,
+ 0x06ca6351e003826f, 0x142929670a0e6e70, 0x27b70a8546d22ffc,
+ 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df,
+ 0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6,
+ 0x92722c851482353b, 0xa2bfe8a14cf10364, 0xa81a664bbc423001,
+ 0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218,
+ 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
+ 0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99,
+ 0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb,
+ 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3, 0x748f82ee5defb2fc,
+ 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec,
+ 0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915,
+ 0xc67178f2e372532b, 0xca273eceea26619c, 0xd186b8c721c0c207,
+ 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba,
+ 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
+ 0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc,
+ 0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a,
+ 0x5fcb6fab3ad6faec, 0x6c44198c4a475817);
+
+@H0384 = (
+ 0xcbbb9d5dc1059ed8, 0x629a292a367cd507, 0x9159015a3070dd17,
+ 0x152fecd8f70e5939, 0x67332667ffc00b31, 0x8eb44a8768581511,
+ 0xdb0c2e0d64f98fa7, 0x47b5481dbefa4fa4);
+
+@H0512 = (
+ 0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b,
+ 0xa54ff53a5f1d36f1, 0x510e527fade682d1, 0x9b05688c2b3e6c1f,
+ 0x1f83d9abfb41bd6b, 0x5be0cd19137e2179);
+
+sub _c_SL64 { my($x, $n) = @_; "($x << $n)" }
+
+sub _c_SR64 {
+ my($x, $n) = @_;
+ my $mask = (1 << (64 - $n)) - 1;
+ "(($x >> $n) & $mask)";
+}
+
+sub _c_ROTRQ {
+ my($x, $n) = @_;
+ "(" . _c_SR64($x, $n) . " | " . _c_SL64($x, 64 - $n) . ")";
+}
+
+sub _c_SIGMAQ0 {
+ my($x) = @_;
+ "(" . _c_ROTRQ($x, 28) . " ^ " . _c_ROTRQ($x, 34) . " ^ " .
+ _c_ROTRQ($x, 39) . ")";
+}
+
+sub _c_SIGMAQ1 {
+ my($x) = @_;
+ "(" . _c_ROTRQ($x, 14) . " ^ " . _c_ROTRQ($x, 18) . " ^ " .
+ _c_ROTRQ($x, 41) . ")";
+}
+
+sub _c_sigmaQ0 {
+ my($x) = @_;
+ "(" . _c_ROTRQ($x, 1) . " ^ " . _c_ROTRQ($x, 8) . " ^ " .
+ _c_SR64($x, 7) . ")";
+}
+
+sub _c_sigmaQ1 {
+ my($x) = @_;
+ "(" . _c_ROTRQ($x, 19) . " ^ " . _c_ROTRQ($x, 61) . " ^ " .
+ _c_SR64($x, 6) . ")";
+}
+
+my $sha512_code = q/
+sub _sha512 {
+ my($self, $block) = @_;
+ my(@N, @W, $a, $b, $c, $d, $e, $f, $g, $h, $T1, $T2);
+
+ @N = unpack("N32", $block);
+ ($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
+ for ( 0 .. 15) { $W[$_] = (($N[2*$_] << 16) << 16) | $N[2*$_+1] }
+ for (16 .. 79) { $W[$_] = / .
+ _c_sigmaQ1(q/$W[$_- 2]/) . q/ + $W[$_- 7] + / .
+ _c_sigmaQ0(q/$W[$_-15]/) . q/ + $W[$_-16] }
+ for ( 0 .. 79) {
+ $T1 = $h + / . _c_SIGMAQ1(q/$e/) .
+ q/ + (($g) ^ (($e) & (($f) ^ ($g)))) +
+ $K512[$_] + $W[$_];
+ $T2 = / . _c_SIGMAQ0(q/$a/) .
+ q/ + ((($a) & ($b)) | (($c) & (($a) | ($b))));
+ $h = $g; $g = $f; $f = $e; $e = $d + $T1;
+ $d = $c; $c = $b; $b = $a; $a = $T1 + $T2;
+ }
+ $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
+ $self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
+ $self->{H}->[6] += $g; $self->{H}->[7] += $h;
+}
+/;
+
+eval($sha512_code);
+$sha512 = \&_sha512;
+
+';
+
+eval($_64bit_code) if $uses64bit;
+
+sub _SETBIT {
+ my($self, $pos) = @_;
+ my @c = unpack("C*", $self->{block});
+ $c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
+ $c[$pos >> 3] |= (0x01 << (7 - $pos % 8));
+ $self->{block} = pack("C*", @c);
+}
+
+sub _CLRBIT {
+ my($self, $pos) = @_;
+ my @c = unpack("C*", $self->{block});
+ $c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
+ $c[$pos >> 3] &= ~(0x01 << (7 - $pos % 8));
+ $self->{block} = pack("C*", @c);
+}
+
+sub _BYTECNT {
+ my($bitcnt) = @_;
+ $bitcnt > 0 ? 1 + (($bitcnt - 1) >> 3) : 0;
+}
+
+sub _digcpy {
+ my($self) = @_;
+ my @dig;
+ for (@{$self->{H}}) {
+ push(@dig, (($_>>16)>>16) & $MAX32) if $self->{alg} >= 384;
+ push(@dig, $_ & $MAX32);
+ }
+ $self->{digest} = pack("N" . ($self->{digestlen}>>2), @dig);
+}
+
+sub _sharewind {
+ my($self) = @_;
+ my $alg = $self->{alg};
+ $self->{block} = ""; $self->{blockcnt} = 0;
+ $self->{blocksize} = $alg <= 256 ? 512 : 1024;
+ for (qw(lenll lenlh lenhl lenhh)) { $self->{$_} = 0 }
+ $self->{digestlen} = $alg == 1 ? 20 : $alg/8;
+ if ($alg == 1) { $self->{sha} = \&_sha1; $self->{H} = [@H01] }
+ elsif ($alg == 224) { $self->{sha} = \&_sha256; $self->{H} = [@H0224] }
+ elsif ($alg == 256) { $self->{sha} = \&_sha256; $self->{H} = [@H0256] }
+ elsif ($alg == 384) { $self->{sha} = $sha512; $self->{H} = [@H0384] }
+ elsif ($alg == 512) { $self->{sha} = $sha512; $self->{H} = [@H0512] }
+ push(@{$self->{H}}, 0) while scalar(@{$self->{H}}) < 8;
+ $self;
+}
+
+sub _shaopen {
+ my($alg) = @_;
+ my($self);
+ return unless grep { $alg == $_ } (1, 224, 256, 384, 512);
+ return if ($alg >= 384 && !$uses64bit);
+ $self->{alg} = $alg;
+ _sharewind($self);
+}
+
+sub _shadirect {
+ my($bitstr, $bitcnt, $self) = @_;
+ my $savecnt = $bitcnt;
+ my $offset = 0;
+ my $blockbytes = $self->{blocksize} >> 3;
+ while ($bitcnt >= $self->{blocksize}) {
+ &{$self->{sha}}($self, substr($bitstr, $offset, $blockbytes));
+ $offset += $blockbytes;
+ $bitcnt -= $self->{blocksize};
+ }
+ if ($bitcnt > 0) {
+ $self->{block} = substr($bitstr, $offset, _BYTECNT($bitcnt));
+ $self->{blockcnt} = $bitcnt;
+ }
+ $savecnt;
+}
+
+sub _shabytes {
+ my($bitstr, $bitcnt, $self) = @_;
+ my($numbits);
+ my $savecnt = $bitcnt;
+ if ($self->{blockcnt} + $bitcnt >= $self->{blocksize}) {
+ $numbits = $self->{blocksize} - $self->{blockcnt};
+ $self->{block} .= substr($bitstr, 0, $numbits >> 3);
+ $bitcnt -= $numbits;
+ $bitstr = substr($bitstr, $numbits >> 3, _BYTECNT($bitcnt));
+ &{$self->{sha}}($self, $self->{block});
+ $self->{block} = "";
+ $self->{blockcnt} = 0;
+ _shadirect($bitstr, $bitcnt, $self);
+ }
+ else {
+ $self->{block} .= substr($bitstr, 0, _BYTECNT($bitcnt));
+ $self->{blockcnt} += $bitcnt;
+ }
+ $savecnt;
+}
+
+sub _shabits {
+ my($bitstr, $bitcnt, $self) = @_;
+ my($i, @buf);
+ my $numbytes = _BYTECNT($bitcnt);
+ my $savecnt = $bitcnt;
+ my $gap = 8 - $self->{blockcnt} % 8;
+ my @c = unpack("C*", $self->{block});
+ my @b = unpack("C" . $numbytes, $bitstr);
+ $c[$self->{blockcnt}>>3] &= (~0 << $gap);
+ $c[$self->{blockcnt}>>3] |= $b[0] >> (8 - $gap);
+ $self->{block} = pack("C*", @c);
+ $self->{blockcnt} += ($bitcnt < $gap) ? $bitcnt : $gap;
+ return($savecnt) if $bitcnt < $gap;
+ if ($self->{blockcnt} == $self->{blocksize}) {
+ &{$self->{sha}}($self, $self->{block});
+ $self->{block} = "";
+ $self->{blockcnt} = 0;
+ }
+ return($savecnt) if ($bitcnt -= $gap) == 0;
+ for ($i = 0; $i < $numbytes - 1; $i++) {
+ $buf[$i] = (($b[$i] << $gap) & 0xff) | ($b[$i+1] >> (8 - $gap));
+ }
+ $buf[$numbytes-1] = ($b[$numbytes-1] << $gap) & 0xff;
+ _shabytes(pack("C*", @buf), $bitcnt, $self);
+ $savecnt;
+}
+
+sub _shawrite {
+ my($bitstr, $bitcnt, $self) = @_;
+ return(0) unless $bitcnt > 0;
+ no integer;
+ if (($self->{lenll} += $bitcnt) >= $TWO32) {
+ $self->{lenll} -= $TWO32;
+ if (++$self->{lenlh} >= $TWO32) {
+ $self->{lenlh} -= $TWO32;
+ if (++$self->{lenhl} >= $TWO32) {
+ $self->{lenhl} -= $TWO32;
+ if (++$self->{lenhh} >= $TWO32) {
+ $self->{lenhh} -= $TWO32;
+ }
+ }
+ }
+ }
+ use integer;
+ my $blockcnt = $self->{blockcnt};
+ return(_shadirect($bitstr, $bitcnt, $self)) if $blockcnt == 0;
+ return(_shabytes ($bitstr, $bitcnt, $self)) if $blockcnt % 8 == 0;
+ return(_shabits ($bitstr, $bitcnt, $self));
+}
+
+sub _shafinish {
+ my($self) = @_;
+ my $LENPOS = $self->{alg} <= 256 ? 448 : 896;
+ _SETBIT($self, $self->{blockcnt}++);
+ while ($self->{blockcnt} > $LENPOS) {
+ if ($self->{blockcnt} < $self->{blocksize}) {
+ _CLRBIT($self, $self->{blockcnt}++);
+ }
+ else {
+ &{$self->{sha}}($self, $self->{block});
+ $self->{block} = "";
+ $self->{blockcnt} = 0;
+ }
+ }
+ while ($self->{blockcnt} < $LENPOS) {
+ _CLRBIT($self, $self->{blockcnt}++);
+ }
+ if ($self->{blocksize} > 512) {
+ $self->{block} .= pack("N", $self->{lenhh} & $MAX32);
+ $self->{block} .= pack("N", $self->{lenhl} & $MAX32);
+ }
+ $self->{block} .= pack("N", $self->{lenlh} & $MAX32);
+ $self->{block} .= pack("N", $self->{lenll} & $MAX32);
+ &{$self->{sha}}($self, $self->{block});
+}
+
+sub _shadigest { my($self) = @_; _digcpy($self); $self->{digest} }
+
+sub _shahex {
+ my($self) = @_;
+ _digcpy($self);
+ join("", unpack("H*", $self->{digest}));
+}
+
+sub _shabase64 {
+ my($self) = @_;
+ _digcpy($self);
+ my $b64 = pack("u", $self->{digest});
+ $b64 =~ s/^.//mg;
+ $b64 =~ s/\n//g;
+ $b64 =~ tr|` -_|AA-Za-z0-9+/|;
+ my $numpads = (3 - length($self->{digest}) % 3) % 3;
+ $b64 =~ s/.{$numpads}$// if $numpads;
+ $b64;
+}
+
+sub _shadsize { my($self) = @_; $self->{digestlen} }
+
+sub _shacpy {
+ my($to, $from) = @_;
+ $to->{alg} = $from->{alg};
+ $to->{sha} = $from->{sha};
+ $to->{H} = [@{$from->{H}}];
+ $to->{block} = $from->{block};
+ $to->{blockcnt} = $from->{blockcnt};
+ $to->{blocksize} = $from->{blocksize};
+ for (qw(lenhh lenhl lenlh lenll)) { $to->{$_} = $from->{$_} }
+ $to->{digestlen} = $from->{digestlen};
+ $to;
+}
+
+sub _shadup { my($self) = @_; my($copy); _shacpy($copy, $self) }
+
+sub _shadump {
+ my $file = shift;
+ $file = "-" if (!defined($file) || $file eq "");
+
+ my $fh = FileHandle->new($file, "w") or return;
+ my $self = shift;
+ my $is32bit = $self->{alg} <= 256;
+ my $fmt = $is32bit ? ":%08x" : ":%016x";
+
+ printf $fh "alg:%d\n", $self->{alg};
+
+ printf $fh "H";
+ for (@{$self->{H}}) { printf $fh $fmt, $is32bit ? $_ & $MAX32 : $_ }
+
+ printf $fh "\nblock";
+ my @c = unpack("C*", $self->{block});
+ push(@c, 0x00) while scalar(@c) < ($self->{blocksize} >> 3);
+ for (@c) { printf $fh ":%02x", $_ }
+
+ printf $fh "\nblockcnt:%u\n", $self->{blockcnt};
+
+ printf $fh "lenhh:%lu\n", $self->{lenhh} & $MAX32;
+ printf $fh "lenhl:%lu\n", $self->{lenhl} & $MAX32;
+ printf $fh "lenlh:%lu\n", $self->{lenlh} & $MAX32;
+ printf $fh "lenll:%lu\n", $self->{lenll} & $MAX32;
+
+ close($fh);
+ $self;
+}
+
+sub _match {
+ my($fh, $tag) = @_;
+ my @f;
+ while (<$fh>) {
+ s/^\s+//;
+ s/\s+$//;
+ next if (/^(#|$)/);
+ @f = split(/[:\s]+/);
+ last;
+ }
+ shift(@f) eq $tag or return;
+ return(@f);
+}
+
+sub _shaload {
+ my $file = shift;
+ $file = "-" if (!defined($file) || $file eq "");
+
+ my $fh = FileHandle->new($file, "r") or return;
+
+ my @f = _match($fh, "alg") or return;
+ my $self = _shaopen(shift(@f)) or return;
+
+ @f = _match($fh, "H") or return;
+ my $numxdigits = $self->{alg} <= 256 ? 8 : 16;
+ for (@f) { $_ = "0" . $_ while length($_) < $numxdigits }
+ for (@f) { $_ = substr($_, 1) while length($_) > $numxdigits }
+ @{$self->{H}} = map { $self->{alg} <= 256 ? hex($_) :
+ ((hex(substr($_, 0, 8)) << 16) << 16) |
+ hex(substr($_, 8)) } @f;
+
+ @f = _match($fh, "block") or return;
+ for (@f) { $self->{block} .= chr(hex($_)) }
+
+ @f = _match($fh, "blockcnt") or return;
+ $self->{blockcnt} = shift(@f);
+ $self->{block} = substr($self->{block},0,_BYTECNT($self->{blockcnt}));
+
+ @f = _match($fh, "lenhh") or return;
+ $self->{lenhh} = shift(@f);
+ @f = _match($fh, "lenhl") or return;
+ $self->{lenhl} = shift(@f);
+ @f = _match($fh, "lenlh") or return;
+ $self->{lenlh} = shift(@f);
+ @f = _match($fh, "lenll") or return;
+ $self->{lenll} = shift(@f);
+
+ close($fh);
+ $self;
+}
+
+# ref. src/hmac.c from Digest::SHA
+
+sub _hmacopen {
+ my($alg, $key) = @_;
+ my($self);
+ $self->{isha} = _shaopen($alg) or return;
+ $self->{osha} = _shaopen($alg) or return;
+ if (length($key) > $self->{osha}->{blocksize} >> 3) {
+ $self->{ksha} = _shaopen($alg) or return;
+ _shawrite($key, length($key) << 3, $self->{ksha});
+ _shafinish($self->{ksha});
+ $key = _shadigest($self->{ksha});
+ }
+ $key .= chr(0x00)
+ while length($key) < $self->{osha}->{blocksize} >> 3;
+ my @k = unpack("C*", $key);
+ for (@k) { $_ ^= 0x5c }
+ _shawrite(pack("C*", @k), $self->{osha}->{blocksize}, $self->{osha});
+ for (@k) { $_ ^= (0x5c ^ 0x36) }
+ _shawrite(pack("C*", @k), $self->{isha}->{blocksize}, $self->{isha});
+ $self;
+}
+
+sub _hmacwrite {
+ my($bitstr, $bitcnt, $self) = @_;
+ _shawrite($bitstr, $bitcnt, $self->{isha});
+}
+
+sub _hmacfinish {
+ my($self) = @_;
+ _shafinish($self->{isha});
+ _shawrite(_shadigest($self->{isha}),
+ $self->{isha}->{digestlen} << 3, $self->{osha});
+ _shafinish($self->{osha});
+}
+
+sub _hmacdigest { my($self) = @_; _shadigest($self->{osha}) }
+sub _hmachex { my($self) = @_; _shahex($self->{osha}) }
+sub _hmacbase64 { my($self) = @_; _shabase64($self->{osha}) }
+
+# SHA and HMAC-SHA functions
+
+my @suffix_extern = ("", "_hex", "_base64");
+my @suffix_intern = ("digest", "hex", "base64");
+
+my($i, $alg);
+for $alg (1, 224, 256, 384, 512) {
+ for $i (0 .. 2) {
+ my $fcn = 'sub sha' . $alg . $suffix_extern[$i] . ' {
+ my $state = _shaopen(' . $alg . ') or return;
+ for (@_) { _shawrite($_, length($_) << 3, $state) }
+ _shafinish($state);
+ _sha' . $suffix_intern[$i] . '($state);
+ }';
+ eval($fcn);
+ push(@EXPORT_OK, 'sha' . $alg . $suffix_extern[$i]);
+ $fcn = 'sub hmac_sha' . $alg . $suffix_extern[$i] . ' {
+ my $state = _hmacopen(' . $alg . ', pop(@_)) or return;
+ for (@_) { _hmacwrite($_, length($_) << 3, $state) }
+ _hmacfinish($state);
+ _hmac' . $suffix_intern[$i] . '($state);
+ }';
+ eval($fcn);
+ push(@EXPORT_OK, 'hmac_sha' . $alg . $suffix_extern[$i]);
+ }
+}
+
+# OOP methods
+
+sub hashsize { my $self = shift; _shadsize($self) << 3 }
+sub algorithm { my $self = shift; $self->{alg} }
+
+sub add {
+ my $self = shift;
+ for (@_) { _shawrite($_, length($_) << 3, $self) }
+ $self;
+}
+
+sub digest {
+ my $self = shift;
+ _shafinish($self);
+ my $rsp = _shadigest($self);
+ _sharewind($self);
+ $rsp;
+}
+
+sub _Hexdigest {
+ my $self = shift;
+ _shafinish($self);
+ my $rsp = _shahex($self);
+ _sharewind($self);
+ $rsp;
+}
+
+sub _B64digest {
+ my $self = shift;
+ _shafinish($self);
+ my $rsp = _shabase64($self);
+ _sharewind($self);
+ $rsp;
+}
+
+sub new {
+ my($class, $alg) = @_;
+ $alg =~ s/\D+//g if defined $alg;
+ if (ref($class)) { # instance method
+ unless (defined($alg) && ($alg != $class->algorithm)) {
+ _sharewind($class);
+ return($class);
+ }
+ my $self = _shaopen($alg) or return;
+ return(_shacpy($class, $self));
+ }
+ $alg = 1 unless defined $alg;
+ my $self = _shaopen($alg) or return;
+ bless($self, $class);
+ $self;
+}
+
+sub clone {
+ my $self = shift;
+ my $copy = _shadup($self) or return;
+ bless($copy, ref($self));
+ return($copy);
+}
+
+*reset = \&new;
+
+sub add_bits {
+ my($self, $data, $nbits) = @_;
+ unless (defined $nbits) {
+ $nbits = length($data);
+ $data = pack("B*", $data);
+ }
+ _shawrite($data, $nbits, $self);
+ return($self);
+}
+
+sub _bail {
+ my $msg = shift;
+
+ require Carp;
+ Carp::croak("$msg: $!");
+}
+
+sub _addfile {
+ my ($self, $handle) = @_;
+
+ my $n;
+ my $buf = "";
+
+ while (($n = read($handle, $buf, 4096))) {
+ $self->add($buf);
+ }
+ _bail("Read failed") unless defined $n;
+
+ $self;
+}
+
+sub _Addfile {
+ my ($self, $file, $mode) = @_;
+
+ return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
+
+ $mode = defined($mode) ? $mode : "";
+ my ($binary, $portable) = map { $_ eq $mode } ("b", "p");
+ my $text = -T $file;
+
+ local *FH;
+ open(FH, "<$file") or _bail("Open failed");
+ binmode(FH) if $binary || $portable;
+
+ unless ($portable && $text) {
+ $self->_addfile(*FH);
+ close(FH);
+ return($self);
+ }
+
+ my ($n1, $n2);
+ my ($buf1, $buf2) = ("", "");
+
+ while (($n1 = read(FH, $buf1, 4096))) {
+ while (substr($buf1, -1) eq "\015") {
+ $n2 = read(FH, $buf2, 4096);
+ _bail("Read failed") unless defined $n2;
+ last unless $n2;
+ $buf1 .= $buf2;
+ }
+ $buf1 =~ s/\015?\015\012/\012/g; # DOS/Windows
+ $buf1 =~ s/\015/\012/g; # early MacOS
+ $self->add($buf1);
+ }
+ _bail("Read failed") unless defined $n1;
+ close(FH);
+
+ $self;
+}
+
+sub dump {
+ my $self = shift;
+ my $file = shift || "";
+
+ _shadump($file, $self) or return;
+ return($self);
+}
+
+sub load {
+ my $class = shift;
+ my $file = shift || "";
+ if (ref($class)) { # instance method
+ my $self = _shaload($file) or return;
+ return(_shacpy($class, $self));
+ }
+ my $self = _shaload($file) or return;
+ bless($self, $class);
+ return($self);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Digest::SHA::PurePerl - Perl implementation of SHA-1/224/256/384/512
+
+=head1 SYNOPSIS
+
+In programs:
+
+ # Functional interface
+
+ use Digest::SHA::PurePerl qw(sha1 sha1_hex sha1_base64 ...);
+
+ $digest = sha1($data);
+ $digest = sha1_hex($data);
+ $digest = sha1_base64($data);
+
+ $digest = sha256($data);
+ $digest = sha384_hex($data);
+ $digest = sha512_base64($data);
+
+ # Object-oriented
+
+ use Digest::SHA::PurePerl;
+
+ $sha = Digest::SHA::PurePerl->new($alg);
+
+ $sha->add($data); # feed data into stream
+
+ $sha->addfile(*F);
+ $sha->addfile($filename);
+
+ $sha->add_bits($bits);
+ $sha->add_bits($data, $nbits);
+
+ $sha_copy = $sha->clone; # if needed, make copy of
+ $sha->dump($file); # current digest state,
+ $sha->load($file); # or save it on disk
+
+ $digest = $sha->digest; # compute digest
+ $digest = $sha->hexdigest;
+ $digest = $sha->b64digest;
+
+From the command line:
+
+ $ shasum files
+
+ $ shasum --help
+
+=head1 SYNOPSIS (HMAC-SHA)
+
+ # Functional interface only
+
+ use Digest::SHA::PurePerl qw(hmac_sha1 hmac_sha1_hex ...);
+
+ $digest = hmac_sha1($data, $key);
+ $digest = hmac_sha224_hex($data, $key);
+ $digest = hmac_sha256_base64($data, $key);
+
+=head1 ABSTRACT
+
+Digest::SHA::PurePerl is a complete implementation of the NIST
+Secure Hash Standard. It gives Perl programmers a convenient way
+to calculate SHA-1, SHA-224, SHA-256, SHA-384, and SHA-512 message
+digests. The module can handle all types of input, including
+partial-byte data.
+
+=head1 DESCRIPTION
+
+Digest::SHA::PurePerl is written entirely in Perl. If your platform
+has a C compiler, you should install the functionally equivalent
+(but much faster) L<Digest::SHA> module.
+
+The programming interface is easy to use: it's the same one found
+in CPAN's L<Digest> module. So, if your applications currently
+use L<Digest::MD5> and you'd prefer the stronger security of SHA,
+it's a simple matter to convert them.
+
+The interface provides two ways to calculate digests: all-at-once,
+or in stages. To illustrate, the following short program computes
+the SHA-256 digest of "hello world" using each approach:
+
+ use Digest::SHA::PurePerl qw(sha256_hex);
+
+ $data = "hello world";
+ @frags = split(//, $data);
+
+ # all-at-once (Functional style)
+ $digest1 = sha256_hex($data);
+
+ # in-stages (OOP style)
+ $state = Digest::SHA::PurePerl->new(256);
+ for (@frags) { $state->add($_) }
+ $digest2 = $state->hexdigest;
+
+ print $digest1 eq $digest2 ?
+ "whew!\n" : "oops!\n";
+
+To calculate the digest of an n-bit message where I<n> is not a
+multiple of 8, use the I<add_bits()> method. For example, consider
+the 446-bit message consisting of the bit-string "110" repeated
+148 times, followed by "11". Here's how to display its SHA-1
+digest:
+
+ use Digest::SHA::PurePerl;
+ $bits = "110" x 148 . "11";
+ $sha = Digest::SHA::PurePerl->new(1)->add_bits($bits);
+ print $sha->hexdigest, "\n";
+
+Note that for larger bit-strings, it's more efficient to use the
+two-argument version I<add_bits($data, $nbits)>, where I<$data> is
+in the customary packed binary format used for Perl strings.
+
+The module also lets you save intermediate SHA states to disk, or
+display them on standard output. The I<dump()> method generates
+portable, human-readable text describing the current state of
+computation. You can subsequently retrieve the file with I<load()>
+to resume where the calculation left off.
+
+To see what a state description looks like, just run the following:
+
+ use Digest::SHA::PurePerl;
+ Digest::SHA::PurePerl->new->add("Shaw" x 1962)->dump;
+
+As an added convenience, the Digest::SHA::PurePerl module offers
+routines to calculate keyed hashes using the HMAC-SHA-1/224/256/384/512
+algorithms. These services exist in functional form only, and
+mimic the style and behavior of the I<sha()>, I<sha_hex()>, and
+I<sha_base64()> functions.
+
+ # Test vector from draft-ietf-ipsec-ciph-sha-256-01.txt
+
+ use Digest::SHA::PurePerl qw(hmac_sha256_hex);
+ print hmac_sha256_hex("Hi There", chr(0x0b) x 32), "\n";
+
+=head1 NIST STATEMENT ON SHA-1
+
+I<NIST was recently informed that researchers had discovered a way
+to "break" the current Federal Information Processing Standard SHA-1
+algorithm, which has been in effect since 1994. The researchers
+have not yet published their complete results, so NIST has not
+confirmed these findings. However, the researchers are a reputable
+research team with expertise in this area.>
+
+I<Due to advances in computing power, NIST already planned to phase
+out SHA-1 in favor of the larger and stronger hash functions (SHA-224,
+SHA-256, SHA-384 and SHA-512) by 2010. New developments should use
+the larger and stronger hash functions.>
+
+ref. L<http://www.csrc.nist.gov/pki/HashWorkshop/NIST%20Statement/Burr_Mar2005.html>
+
+=head1 PADDING OF BASE64 DIGESTS
+
+By convention, CPAN Digest modules do B<not> pad their Base64 output.
+Problems can occur when feeding such digests to other software that
+expects properly padded Base64 encodings.
+
+For the time being, any necessary padding must be done by the user.
+Fortunately, this is a simple operation: if the length of a Base64-encoded
+digest isn't a multiple of 4, simply append "=" characters to the end
+of the digest until it is:
+
+ while (length($b64_digest) % 4) {
+ $b64_digest .= '=';
+ }
+
+To illustrate, I<sha256_base64("abc")> is computed to be
+
+ ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0
+
+which has a length of 43. So, the properly padded version is
+
+ ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0=
+
+=head1 EXPORT
+
+None by default.
+
+=head1 EXPORTABLE FUNCTIONS
+
+Provided your Perl installation supports 64-bit integers, all of
+these functions will be available for use. Otherwise, you won't
+be able to perform the SHA-384 and SHA-512 transforms, both of
+which require 64-bit operations.
+
+I<Functional style>
+
+=over 4
+
+=item B<sha1($data, ...)>
+
+=item B<sha224($data, ...)>
+
+=item B<sha256($data, ...)>
+
+=item B<sha384($data, ...)>
+
+=item B<sha512($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a binary string.
+
+=item B<sha1_hex($data, ...)>
+
+=item B<sha224_hex($data, ...)>
+
+=item B<sha256_hex($data, ...)>
+
+=item B<sha384_hex($data, ...)>
+
+=item B<sha512_hex($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a hexadecimal string.
+
+=item B<sha1_base64($data, ...)>
+
+=item B<sha224_base64($data, ...)>
+
+=item B<sha256_base64($data, ...)>
+
+=item B<sha384_base64($data, ...)>
+
+=item B<sha512_base64($data, ...)>
+
+Logically joins the arguments into a single string, and returns
+its SHA-1/224/256/384/512 digest encoded as a Base64 string.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+I<OOP style>
+
+=over 4
+
+=item B<new($alg)>
+
+Returns a new Digest::SHA::PurePerl object. Allowed values for
+I<$alg> are 1, 224, 256, 384, or 512. It's also possible to use
+common string representations of the algorithm (e.g. "sha256",
+"SHA-384"). If the argument is missing, SHA-1 will be used by
+default.
+
+Invoking I<new> as an instance method will not create a new object;
+instead, it will simply reset the object to the initial state
+associated with I<$alg>. If the argument is missing, the object
+will continue using the same algorithm that was selected at creation.
+
+=item B<reset($alg)>
+
+This method has exactly the same effect as I<new($alg)>. In fact,
+I<reset> is just an alias for I<new>.
+
+=item B<hashsize>
+
+Returns the number of digest bits for this object. The values are
+160, 224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384,
+and SHA-512, respectively.
+
+=item B<algorithm>
+
+Returns the digest algorithm for this object. The values are 1,
+224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384, and
+SHA-512, respectively.
+
+=item B<clone>
+
+Returns a duplicate copy of the object.
+
+=item B<add($data, ...)>
+
+Logically joins the arguments into a single string, and uses it to
+update the current digest state. In other words, the following
+statements have the same effect:
+
+ $sha->add("a"); $sha->add("b"); $sha->add("c");
+ $sha->add("a")->add("b")->add("c");
+ $sha->add("a", "b", "c");
+ $sha->add("abc");
+
+The return value is the updated object itself.
+
+=item B<add_bits($data, $nbits)>
+
+=item B<add_bits($bits)>
+
+Updates the current digest state by appending bits to it. The
+return value is the updated object itself.
+
+The first form causes the most-significant I<$nbits> of I<$data>
+to be appended to the stream. The I<$data> argument is in the
+customary binary format used for Perl strings.
+
+The second form takes an ASCII string of "0" and "1" characters as
+its argument. It's equivalent to
+
+ $sha->add_bits(pack("B*", $bits), length($bits));
+
+So, the following two statements do the same thing:
+
+ $sha->add_bits("111100001010");
+ $sha->add_bits("\xF0\xA0", 12);
+
+=item B<addfile(*FILE)>
+
+Reads from I<FILE> until EOF, and appends that data to the current
+state. The return value is the updated object itself.
+
+=item B<addfile($filename [, $mode])>
+
+Reads the contents of I<$filename>, and appends that data to the current
+state. The return value is the updated object itself.
+
+By default, I<$filename> is simply opened and read; no special modes
+or I/O disciplines are used. To change this, set the optional I<$mode>
+argument to one of the following values:
+
+ "b" read file in binary mode
+
+ "p" use portable mode
+
+The "p" mode is handy since it ensures that the digest value of
+I<$filename> will be the same when computed on different operating
+systems. It accomplishes this by internally translating all newlines
+in text files to UNIX format before calculating the digest; on the other
+hand, binary files are read in raw mode with no translation whatsoever.
+
+For a fuller discussion of newline formats, refer to CPAN module
+L<File::LocalizeNewlines>. Its "universal line separator" regex forms
+the basis of I<addfile>'s portable mode processing.
+
+=item B<dump($filename)>
+
+Provides persistent storage of intermediate SHA states by writing
+a portable, human-readable representation of the current state to
+I<$filename>. If the argument is missing, or equal to the empty
+string, the state information will be written to STDOUT.
+
+=item B<load($filename)>
+
+Returns a Digest::SHA::PurePerl object representing the intermediate
+SHA state that was previously dumped to I<$filename>. If called
+as a class method, a new object is created; if called as an instance
+method, the object is reset to the state contained in I<$filename>.
+If the argument is missing, or equal to the empty string, the state
+information will be read from STDIN.
+
+=item B<digest>
+
+Returns the digest encoded as a binary string.
+
+Note that the I<digest> method is a read-once operation. Once it
+has been performed, the Digest::SHA::PurePerl object is automatically
+reset in preparation for calculating another digest value. Call
+I<$sha-E<gt>clone-E<gt>digest> if it's necessary to preserve the
+original digest state.
+
+=item B<hexdigest>
+
+Returns the digest encoded as a hexadecimal string.
+
+Like I<digest>, this method is a read-once operation. Call
+I<$sha-E<gt>clone-E<gt>hexdigest> if it's necessary to preserve
+the original digest state.
+
+This method is inherited if L<Digest::base> is installed on your
+system. Otherwise, a functionally equivalent substitute is used.
+
+=item B<b64digest>
+
+Returns the digest encoded as a Base64 string.
+
+Like I<digest>, this method is a read-once operation. Call
+I<$sha-E<gt>clone-E<gt>b64digest> if it's necessary to preserve
+the original digest state.
+
+This method is inherited if L<Digest::base> is installed on your
+system. Otherwise, a functionally equivalent substitute is used.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+I<HMAC-SHA-1/224/256/384/512>
+
+=over 4
+
+=item B<hmac_sha1($data, $key)>
+
+=item B<hmac_sha224($data, $key)>
+
+=item B<hmac_sha256($data, $key)>
+
+=item B<hmac_sha384($data, $key)>
+
+=item B<hmac_sha512($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a binary string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+=item B<hmac_sha1_hex($data, $key)>
+
+=item B<hmac_sha224_hex($data, $key)>
+
+=item B<hmac_sha256_hex($data, $key)>
+
+=item B<hmac_sha384_hex($data, $key)>
+
+=item B<hmac_sha512_hex($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a hexadecimal string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+=item B<hmac_sha1_base64($data, $key)>
+
+=item B<hmac_sha224_base64($data, $key)>
+
+=item B<hmac_sha256_base64($data, $key)>
+
+=item B<hmac_sha384_base64($data, $key)>
+
+=item B<hmac_sha512_base64($data, $key)>
+
+Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
+with the result encoded as a Base64 string. Multiple I<$data>
+arguments are allowed, provided that I<$key> is the last argument
+in the list.
+
+It's important to note that the resulting string does B<not> contain
+the padding characters typical of Base64 encodings. This omission is
+deliberate, and is done to maintain compatibility with the family of
+CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
+
+=back
+
+=head1 SEE ALSO
+
+L<Digest>, L<Digest::SHA>
+
+The Secure Hash Standard (FIPS PUB 180-2) can be found at:
+
+L<http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>
+
+The Keyed-Hash Message Authentication Code (HMAC):
+
+L<http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>
+
+=head1 AUTHOR
+
+ Mark Shelor <mshelor@cpan.org>
+
+=head1 ACKNOWLEDGMENTS
+
+The author is particularly grateful to
+
+ Gisle Aas
+ Chris Carey
+ Jim Doble
+ Julius Duque
+ Jeffrey Friedl
+ Robert Gilmour
+ Brian Gladman
+ Adam Kennedy
+ Andy Lester
+ Alex Muntada
+ Steve Peters
+ Chris Skiscim
+ Martin Thurn
+ Gunnar Wolf
+ Adam Woodbury
+
+for their valuable comments and suggestions.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2003-2007 Mark Shelor
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+L<perlartistic>
+
+=cut
--- /dev/null
+package HTTP::Config;
+
+use strict;
+use URI;
+use vars qw($VERSION);
+
+$VERSION = "6.00";
+
+sub new {
+ my $class = shift;
+ return bless [], $class;
+}
+
+sub entries {
+ my $self = shift;
+ @$self;
+}
+
+sub empty {
+ my $self = shift;
+ not @$self;
+}
+
+sub add {
+ if (@_ == 2) {
+ my $self = shift;
+ push(@$self, shift);
+ return;
+ }
+ my($self, %spec) = @_;
+ push(@$self, \%spec);
+ return;
+}
+
+sub find2 {
+ my($self, %spec) = @_;
+ my @found;
+ my @rest;
+ ITEM:
+ for my $item (@$self) {
+ for my $k (keys %spec) {
+ if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
+ push(@rest, $item);
+ next ITEM;
+ }
+ }
+ push(@found, $item);
+ }
+ return \@found unless wantarray;
+ return \@found, \@rest;
+}
+
+sub find {
+ my $self = shift;
+ my $f = $self->find2(@_);
+ return @$f if wantarray;
+ return $f->[0];
+}
+
+sub remove {
+ my($self, %spec) = @_;
+ my($removed, $rest) = $self->find2(%spec);
+ @$self = @$rest if @$removed;
+ return @$removed;
+}
+
+my %MATCH = (
+ m_scheme => sub {
+ my($v, $uri) = @_;
+ return $uri->_scheme eq $v; # URI known to be canonical
+ },
+ m_secure => sub {
+ my($v, $uri) = @_;
+ my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
+ return $secure == !!$v;
+ },
+ m_host_port => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("host_port");
+ return $uri->host_port eq $v, 7;
+ },
+ m_host => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("host");
+ return $uri->host eq $v, 6;
+ },
+ m_port => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("port");
+ return $uri->port eq $v;
+ },
+ m_domain => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("host");
+ my $h = $uri->host;
+ $h = "$h.local" unless $h =~ /\./;
+ $v = ".$v" unless $v =~ /^\./;
+ return length($v), 5 if substr($h, -length($v)) eq $v;
+ return 0;
+ },
+ m_path => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("path");
+ return $uri->path eq $v, 4;
+ },
+ m_path_prefix => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("path");
+ my $path = $uri->path;
+ my $len = length($v);
+ return $len, 3 if $path eq $v;
+ return 0 if length($path) <= $len;
+ $v .= "/" unless $v =~ m,/\z,,;
+ return $len, 3 if substr($path, 0, length($v)) eq $v;
+ return 0;
+ },
+ m_path_match => sub {
+ my($v, $uri) = @_;
+ return unless $uri->can("path");
+ return $uri->path =~ $v;
+ },
+ m_uri__ => sub {
+ my($v, $k, $uri) = @_;
+ return unless $uri->can($k);
+ return 1 unless defined $v;
+ return $uri->$k eq $v;
+ },
+ m_method => sub {
+ my($v, $uri, $request) = @_;
+ return $request && $request->method eq $v;
+ },
+ m_proxy => sub {
+ my($v, $uri, $request) = @_;
+ return $request && ($request->{proxy} || "") eq $v;
+ },
+ m_code => sub {
+ my($v, $uri, $request, $response) = @_;
+ $v =~ s/xx\z//;
+ return unless $response;
+ return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
+ },
+ m_media_type => sub { # for request too??
+ my($v, $uri, $request, $response) = @_;
+ return unless $response;
+ return 1, 1 if $v eq "*/*";
+ my $ct = $response->content_type;
+ return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
+ return 3, 1 if $v eq "html" && $response->content_is_html;
+ return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
+ return 10, 1 if $v eq $ct;
+ return 0;
+ },
+ m_header__ => sub {
+ my($v, $k, $uri, $request, $response) = @_;
+ return unless $request;
+ return 1 if $request->header($k) eq $v;
+ return 1 if $response && $response->header($k) eq $v;
+ return 0;
+ },
+ m_response_attr__ => sub {
+ my($v, $k, $uri, $request, $response) = @_;
+ return unless $response;
+ return 1 if !defined($v) && exists $response->{$k};
+ return 0 unless exists $response->{$k};
+ return 1 if $response->{$k} eq $v;
+ return 0;
+ },
+);
+
+sub matching {
+ my $self = shift;
+ if (@_ == 1) {
+ if ($_[0]->can("request")) {
+ unshift(@_, $_[0]->request);
+ unshift(@_, undef) unless defined $_[0];
+ }
+ unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
+ }
+ my($uri, $request, $response) = @_;
+ $uri = URI->new($uri) unless ref($uri);
+
+ my @m;
+ ITEM:
+ for my $item (@$self) {
+ my $order;
+ for my $ikey (keys %$item) {
+ my $mkey = $ikey;
+ my $k;
+ $k = $1 if $mkey =~ s/__(.*)/__/;
+ if (my $m = $MATCH{$mkey}) {
+ #print "$ikey $mkey\n";
+ my($c, $o);
+ my @arg = (
+ defined($k) ? $k : (),
+ $uri, $request, $response
+ );
+ my $v = $item->{$ikey};
+ $v = [$v] unless ref($v) eq "ARRAY";
+ for (@$v) {
+ ($c, $o) = $m->($_, @arg);
+ #print " - $_ ==> $c $o\n";
+ last if $c;
+ }
+ next ITEM unless $c;
+ $order->[$o || 0] += $c;
+ }
+ }
+ $order->[7] ||= 0;
+ $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
+ push(@m, $item);
+ }
+ @m = sort { $b->{_order} cmp $a->{_order} } @m;
+ delete $_->{_order} for @m;
+ return @m if wantarray;
+ return $m[0];
+}
+
+sub add_item {
+ my $self = shift;
+ my $item = shift;
+ return $self->add(item => $item, @_);
+}
+
+sub remove_items {
+ my $self = shift;
+ return map $_->{item}, $self->remove(@_);
+}
+
+sub matching_items {
+ my $self = shift;
+ return map $_->{item}, $self->matching(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Config - Configuration for request and response objects
+
+=head1 SYNOPSIS
+
+ use HTTP::Config;
+ my $c = HTTP::Config->new;
+ $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
+
+ use HTTP::Request;
+ my $request = HTTP::Request->new(GET => "http://www.example.com");
+
+ if (my @m = $c->matching($request)) {
+ print "Yadayada\n" if $m[0]->{verbose};
+ }
+
+=head1 DESCRIPTION
+
+An C<HTTP::Config> object is a list of entries that
+can be matched against request or request/response pairs. Its
+purpose is to hold configuration data that can be looked up given a
+request or response object.
+
+Each configuration entry is a hash. Some keys specify matching to
+occur against attributes of request/response objects. Other keys can
+be used to hold user data.
+
+The following methods are provided:
+
+=over 4
+
+=item $conf = HTTP::Config->new
+
+Constructs a new empty C<HTTP::Config> object and returns it.
+
+=item $conf->entries
+
+Returns the list of entries in the configuration object.
+In scalar context returns the number of entries.
+
+=item $conf->empty
+
+Return true if there are no entries in the configuration object.
+This is just a shorthand for C<< not $conf->entries >>.
+
+=item $conf->add( %matchspec, %other )
+
+=item $conf->add( \%entry )
+
+Adds a new entry to the configuration.
+You can either pass separate key/value pairs or a hash reference.
+
+=item $conf->remove( %spec )
+
+Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
+If %spec is empty this will match all entries; so it will empty the configuation object.
+
+=item $conf->matching( $uri, $request, $response )
+
+=item $conf->matching( $uri )
+
+=item $conf->matching( $request )
+
+=item $conf->matching( $response )
+
+Returns the entries that match the given $uri, $request and $response triplet.
+
+If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
+If called with a single $response object, then the request object is obtained by calling its 'request' method;
+and then the $uri is obtained as if a single $request was provided.
+
+The entries are returned with the most specific matches first.
+In scalar context returns the most specific match or C<undef> in none match.
+
+=item $conf->add_item( $item, %matchspec )
+
+=item $conf->remove_items( %spec )
+
+=item $conf->matching_items( $uri, $request, $response )
+
+Wrappers that hides the entries themselves.
+
+=back
+
+=head2 Matching
+
+The following keys on a configuration entry specify matching. For all
+of these you can provide an array of values instead of a single value.
+The entry matches if at least one of the values in the array matches.
+
+Entries that require match against a response object attribute will never match
+unless a response object was provided.
+
+=over
+
+=item m_scheme => $scheme
+
+Matches if the URI uses the specified scheme; e.g. "http".
+
+=item m_secure => $bool
+
+If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
+is FALSE; matches if the URI does not use a secure scheme. An example
+of a secure scheme is "https".
+
+=item m_host_port => "$hostname:$port"
+
+Matches if the URI's host_port method return the specified value.
+
+=item m_host => $hostname
+
+Matches if the URI's host method returns the specified value.
+
+=item m_port => $port
+
+Matches if the URI's port method returns the specified value.
+
+=item m_domain => ".$domain"
+
+Matches if the URI's host method return a value that within the given
+domain. The hostname "www.example.com" will for instance match the
+domain ".com".
+
+=item m_path => $path
+
+Matches if the URI's path method returns the specified value.
+
+=item m_path_prefix => $path
+
+Matches if the URI's path is the specified path or has the specified
+path as prefix.
+
+=item m_path_match => $Regexp
+
+Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
+
+=item m_method => $method
+
+Matches if the request method matches the specified value. Eg. "GET" or "POST".
+
+=item m_code => $digit
+
+=item m_code => $status_code
+
+Matches if the response status code matches. If a single digit is
+specified; matches for all response status codes beginning with that digit.
+
+=item m_proxy => $url
+
+Matches if the request is to be sent to the given Proxy server.
+
+=item m_media_type => "*/*"
+
+=item m_media_type => "text/*"
+
+=item m_media_type => "html"
+
+=item m_media_type => "xhtml"
+
+=item m_media_type => "text/html"
+
+Matches if the response media type matches.
+
+With a value of "html" matches if $response->content_is_html returns TRUE.
+With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
+
+=item m_uri__I<$method> => undef
+
+Matches if the URI object provides the method.
+
+=item m_uri__I<$method> => $string
+
+Matches if the URI's $method method returns the given value.
+
+=item m_header__I<$field> => $string
+
+Matches if either the request or the response have a header $field with the given value.
+
+=item m_response_attr__I<$key> => undef
+
+=item m_response_attr__I<$key> => $string
+
+Matches if the response object has that key, or the entry has the given value.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<HTTP::Request>, L<HTTP::Response>
+
+=head1 COPYRIGHT
+
+Copyright 2008, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package HTTP::Headers;
+
+use strict;
+use Carp ();
+
+use vars qw($VERSION $TRANSLATE_UNDERSCORE);
+$VERSION = "6.00";
+
+# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
+# as a replacement for '-' in header field names.
+$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
+
+# "Good Practice" order of HTTP message headers:
+# - General-Headers
+# - Request-Headers
+# - Response-Headers
+# - Entity-Headers
+
+my @general_headers = qw(
+ Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
+ Via Warning
+);
+
+my @request_headers = qw(
+ Accept Accept-Charset Accept-Encoding Accept-Language
+ Authorization Expect From Host
+ If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
+ Max-Forwards Proxy-Authorization Range Referer TE User-Agent
+);
+
+my @response_headers = qw(
+ Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
+ Vary WWW-Authenticate
+);
+
+my @entity_headers = qw(
+ Allow Content-Encoding Content-Language Content-Length Content-Location
+ Content-MD5 Content-Range Content-Type Expires Last-Modified
+);
+
+my %entity_header = map { lc($_) => 1 } @entity_headers;
+
+my @header_order = (
+ @general_headers,
+ @request_headers,
+ @response_headers,
+ @entity_headers,
+);
+
+# Make alternative representations of @header_order. This is used
+# for sorting and case matching.
+my %header_order;
+my %standard_case;
+
+{
+ my $i = 0;
+ for (@header_order) {
+ my $lc = lc $_;
+ $header_order{$lc} = ++$i;
+ $standard_case{$lc} = $_;
+ }
+}
+
+
+
+sub new
+{
+ my($class) = shift;
+ my $self = bless {}, $class;
+ $self->header(@_) if @_; # set up initial headers
+ $self;
+}
+
+
+sub header
+{
+ my $self = shift;
+ Carp::croak('Usage: $h->header($field, ...)') unless @_;
+ my(@old);
+ my %seen;
+ while (@_) {
+ my $field = shift;
+ my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
+ @old = $self->_header($field, shift, $op);
+ }
+ return @old if wantarray;
+ return $old[0] if @old <= 1;
+ join(", ", @old);
+}
+
+sub clear
+{
+ my $self = shift;
+ %$self = ();
+}
+
+
+sub push_header
+{
+ my $self = shift;
+ return $self->_header(@_, 'PUSH_H') if @_ == 2;
+ while (@_) {
+ $self->_header(splice(@_, 0, 2), 'PUSH_H');
+ }
+}
+
+
+sub init_header
+{
+ Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
+ shift->_header(@_, 'INIT');
+}
+
+
+sub remove_header
+{
+ my($self, @fields) = @_;
+ my $field;
+ my @values;
+ foreach $field (@fields) {
+ $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
+ my $v = delete $self->{lc $field};
+ push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
+ }
+ return @values;
+}
+
+sub remove_content_headers
+{
+ my $self = shift;
+ unless (defined(wantarray)) {
+ # fast branch that does not create return object
+ delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
+ return;
+ }
+
+ my $c = ref($self)->new;
+ for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
+ $c->{$f} = delete $self->{$f};
+ }
+ $c;
+}
+
+
+sub _header
+{
+ my($self, $field, $val, $op) = @_;
+
+ unless ($field =~ /^:/) {
+ $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
+ my $old = $field;
+ $field = lc $field;
+ unless(defined $standard_case{$field}) {
+ # generate a %standard_case entry for this field
+ $old =~ s/\b(\w)/\u$1/g;
+ $standard_case{$field} = $old;
+ }
+ }
+
+ $op ||= defined($val) ? 'SET' : 'GET';
+ if ($op eq 'PUSH_H') {
+ # Like PUSH but where we don't care about the return value
+ if (exists $self->{$field}) {
+ my $h = $self->{$field};
+ if (ref($h) eq 'ARRAY') {
+ push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
+ }
+ else {
+ $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
+ }
+ return;
+ }
+ $self->{$field} = $val;
+ return;
+ }
+
+ my $h = $self->{$field};
+ my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
+
+ unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
+ if (defined($val)) {
+ my @new = ($op eq 'PUSH') ? @old : ();
+ if (ref($val) ne 'ARRAY') {
+ push(@new, $val);
+ }
+ else {
+ push(@new, @$val);
+ }
+ $self->{$field} = @new > 1 ? \@new : $new[0];
+ }
+ elsif ($op ne 'PUSH') {
+ delete $self->{$field};
+ }
+ }
+ @old;
+}
+
+
+sub _sorted_field_names
+{
+ my $self = shift;
+ return [ sort {
+ ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
+ $a cmp $b
+ } keys %$self ];
+}
+
+
+sub header_field_names {
+ my $self = shift;
+ return map $standard_case{$_} || $_, @{ $self->_sorted_field_names },
+ if wantarray;
+ return keys %$self;
+}
+
+
+sub scan
+{
+ my($self, $sub) = @_;
+ my $key;
+ for $key (@{ $self->_sorted_field_names }) {
+ next if substr($key, 0, 1) eq '_';
+ my $vals = $self->{$key};
+ if (ref($vals) eq 'ARRAY') {
+ my $val;
+ for $val (@$vals) {
+ $sub->($standard_case{$key} || $key, $val);
+ }
+ }
+ else {
+ $sub->($standard_case{$key} || $key, $vals);
+ }
+ }
+}
+
+
+sub as_string
+{
+ my($self, $endl) = @_;
+ $endl = "\n" unless defined $endl;
+
+ my @result = ();
+ for my $key (@{ $self->_sorted_field_names }) {
+ next if index($key, '_') == 0;
+ my $vals = $self->{$key};
+ if ( ref($vals) eq 'ARRAY' ) {
+ for my $val (@$vals) {
+ my $field = $standard_case{$key} || $key;
+ $field =~ s/^://;
+ if ( index($val, "\n") >= 0 ) {
+ $val = _process_newline($val, $endl);
+ }
+ push @result, $field . ': ' . $val;
+ }
+ }
+ else {
+ my $field = $standard_case{$key} || $key;
+ $field =~ s/^://;
+ if ( index($vals, "\n") >= 0 ) {
+ $vals = _process_newline($vals, $endl);
+ }
+ push @result, $field . ': ' . $vals;
+ }
+ }
+
+ join($endl, @result, '');
+}
+
+sub _process_newline {
+ local $_ = shift;
+ my $endl = shift;
+ # must handle header values with embedded newlines with care
+ s/\s+$//; # trailing newlines and space must go
+ s/\n(\x0d?\n)+/\n/g; # no empty lines
+ s/\n([^\040\t])/\n $1/g; # intial space for continuation
+ s/\n/$endl/g; # substitute with requested line ending
+ $_;
+}
+
+
+
+if (eval { require Storable; 1 }) {
+ *clone = \&Storable::dclone;
+} else {
+ *clone = sub {
+ my $self = shift;
+ my $clone = HTTP::Headers->new;
+ $self->scan(sub { $clone->push_header(@_);} );
+ $clone;
+ };
+}
+
+
+sub _date_header
+{
+ require HTTP::Date;
+ my($self, $header, $time) = @_;
+ my($old) = $self->_header($header);
+ if (defined $time) {
+ $self->_header($header, HTTP::Date::time2str($time));
+ }
+ $old =~ s/;.*// if defined($old);
+ HTTP::Date::str2time($old);
+}
+
+
+sub date { shift->_date_header('Date', @_); }
+sub expires { shift->_date_header('Expires', @_); }
+sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
+sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
+sub last_modified { shift->_date_header('Last-Modified', @_); }
+
+# This is used as a private LWP extension. The Client-Date header is
+# added as a timestamp to a response when it has been received.
+sub client_date { shift->_date_header('Client-Date', @_); }
+
+# The retry_after field is dual format (can also be a expressed as
+# number of seconds from now), so we don't provide an easy way to
+# access it until we have know how both these interfaces can be
+# addressed. One possibility is to return a negative value for
+# relative seconds and a positive value for epoch based time values.
+#sub retry_after { shift->_date_header('Retry-After', @_); }
+
+sub content_type {
+ my $self = shift;
+ my $ct = $self->{'content-type'};
+ $self->{'content-type'} = shift if @_;
+ $ct = $ct->[0] if ref($ct) eq 'ARRAY';
+ return '' unless defined($ct) && length($ct);
+ my @ct = split(/;\s*/, $ct, 2);
+ for ($ct[0]) {
+ s/\s+//g;
+ $_ = lc($_);
+ }
+ wantarray ? @ct : $ct[0];
+}
+
+sub content_type_charset {
+ my $self = shift;
+ require HTTP::Headers::Util;
+ my $h = $self->{'content-type'};
+ $h = $h->[0] if ref($h);
+ $h = "" unless defined $h;
+ my @v = HTTP::Headers::Util::split_header_words($h);
+ if (@v) {
+ my($ct, undef, %ct_param) = @{$v[0]};
+ my $charset = $ct_param{charset};
+ if ($ct) {
+ $ct = lc($ct);
+ $ct =~ s/\s+//;
+ }
+ if ($charset) {
+ $charset = uc($charset);
+ $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
+ undef($charset) if $charset eq "";
+ }
+ return $ct, $charset if wantarray;
+ return $charset;
+ }
+ return undef, undef if wantarray;
+ return undef;
+}
+
+sub content_is_text {
+ my $self = shift;
+ return $self->content_type =~ m,^text/,;
+}
+
+sub content_is_html {
+ my $self = shift;
+ return $self->content_type eq 'text/html' || $self->content_is_xhtml;
+}
+
+sub content_is_xhtml {
+ my $ct = shift->content_type;
+ return $ct eq "application/xhtml+xml" ||
+ $ct eq "application/vnd.wap.xhtml+xml";
+}
+
+sub content_is_xml {
+ my $ct = shift->content_type;
+ return 1 if $ct eq "text/xml";
+ return 1 if $ct eq "application/xml";
+ return 1 if $ct =~ /\+xml$/;
+ return 0;
+}
+
+sub referer {
+ my $self = shift;
+ if (@_ && $_[0] =~ /#/) {
+ # Strip fragment per RFC 2616, section 14.36.
+ my $uri = shift;
+ if (ref($uri)) {
+ $uri = $uri->clone;
+ $uri->fragment(undef);
+ }
+ else {
+ $uri =~ s/\#.*//;
+ }
+ unshift @_, $uri;
+ }
+ ($self->_header('Referer', @_))[0];
+}
+*referrer = \&referer; # on tchrist's request
+
+sub title { (shift->_header('Title', @_))[0] }
+sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
+sub content_language { (shift->_header('Content-Language', @_))[0] }
+sub content_length { (shift->_header('Content-Length', @_))[0] }
+
+sub user_agent { (shift->_header('User-Agent', @_))[0] }
+sub server { (shift->_header('Server', @_))[0] }
+
+sub from { (shift->_header('From', @_))[0] }
+sub warning { (shift->_header('Warning', @_))[0] }
+
+sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
+sub authorization { (shift->_header('Authorization', @_))[0] }
+
+sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
+sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
+
+sub authorization_basic { shift->_basic_auth("Authorization", @_) }
+sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
+
+sub _basic_auth {
+ require MIME::Base64;
+ my($self, $h, $user, $passwd) = @_;
+ my($old) = $self->_header($h);
+ if (defined $user) {
+ Carp::croak("Basic authorization user name can't contain ':'")
+ if $user =~ /:/;
+ $passwd = '' unless defined $passwd;
+ $self->_header($h => 'Basic ' .
+ MIME::Base64::encode("$user:$passwd", ''));
+ }
+ if (defined $old && $old =~ s/^\s*Basic\s+//) {
+ my $val = MIME::Base64::decode($old);
+ return $val unless wantarray;
+ return split(/:/, $val, 2);
+ }
+ return;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Headers - Class encapsulating HTTP Message headers
+
+=head1 SYNOPSIS
+
+ require HTTP::Headers;
+ $h = HTTP::Headers->new;
+
+ $h->header('Content-Type' => 'text/plain'); # set
+ $ct = $h->header('Content-Type'); # get
+ $h->remove_header('Content-Type'); # delete
+
+=head1 DESCRIPTION
+
+The C<HTTP::Headers> class encapsulates HTTP-style message headers.
+The headers consist of attribute-value pairs also called fields, which
+may be repeated, and which are printed in a particular order. The
+field names are cases insensitive.
+
+Instances of this class are usually created as member variables of the
+C<HTTP::Request> and C<HTTP::Response> classes, internal to the
+library.
+
+The following methods are available:
+
+=over 4
+
+=item $h = HTTP::Headers->new
+
+Constructs a new C<HTTP::Headers> object. You might pass some initial
+attribute-value pairs as parameters to the constructor. I<E.g.>:
+
+ $h = HTTP::Headers->new(
+ Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
+ Content_Type => 'text/html; version=3.2',
+ Content_Base => 'http://www.perl.org/');
+
+The constructor arguments are passed to the C<header> method which is
+described below.
+
+=item $h->clone
+
+Returns a copy of this C<HTTP::Headers> object.
+
+=item $h->header( $field )
+
+=item $h->header( $field => $value )
+
+=item $h->header( $f1 => $v1, $f2 => $v2, ... )
+
+Get or set the value of one or more header fields. The header field
+name ($field) is not case sensitive. To make the life easier for perl
+users who wants to avoid quoting before the => operator, you can use
+'_' as a replacement for '-' in header names.
+
+The header() method accepts multiple ($field => $value) pairs, which
+means that you can update several fields with a single invocation.
+
+The $value argument may be a plain string or a reference to an array
+of strings for a multi-valued field. If the $value is provided as
+C<undef> then the field is removed. If the $value is not given, then
+that header field will remain unchanged.
+
+The old value (or values) of the last of the header fields is returned.
+If no such field exists C<undef> will be returned.
+
+A multi-valued field will be returned as separate values in list
+context and will be concatenated with ", " as separator in scalar
+context. The HTTP spec (RFC 2616) promise that joining multiple
+values in this way will not change the semantic of a header field, but
+in practice there are cases like old-style Netscape cookies (see
+L<HTTP::Cookies>) where "," is used as part of the syntax of a single
+field value.
+
+Examples:
+
+ $header->header(MIME_Version => '1.0',
+ User_Agent => 'My-Web-Client/0.01');
+ $header->header(Accept => "text/html, text/plain, image/*");
+ $header->header(Accept => [qw(text/html text/plain image/*)]);
+ @accepts = $header->header('Accept'); # get multiple values
+ $accepts = $header->header('Accept'); # get values as a single string
+
+=item $h->push_header( $field => $value )
+
+=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
+
+Add a new field value for the specified header field. Previous values
+for the same field are retained.
+
+As for the header() method, the field name ($field) is not case
+sensitive and '_' can be used as a replacement for '-'.
+
+The $value argument may be a scalar or a reference to a list of
+scalars.
+
+ $header->push_header(Accept => 'image/jpeg');
+ $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
+
+=item $h->init_header( $field => $value )
+
+Set the specified header to the given value, but only if no previous
+value for that field is set.
+
+The header field name ($field) is not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The $value argument may be a scalar or a reference to a list of
+scalars.
+
+=item $h->remove_header( $field, ... )
+
+This function removes the header fields with the specified names.
+
+The header field names ($field) are not case sensitive and '_'
+can be used as a replacement for '-'.
+
+The return value is the values of the fields removed. In scalar
+context the number of fields removed is returned.
+
+Note that if you pass in multiple field names then it is generally not
+possible to tell which of the returned values belonged to which field.
+
+=item $h->remove_content_headers
+
+This will remove all the header fields used to describe the content of
+a message. All header field names prefixed with C<Content-> fall
+into this category, as well as C<Allow>, C<Expires> and
+C<Last-Modified>. RFC 2616 denotes these fields as I<Entity Header
+Fields>.
+
+The return value is a new C<HTTP::Headers> object that contains the
+removed headers only.
+
+=item $h->clear
+
+This will remove all header fields.
+
+=item $h->header_field_names
+
+Returns the list of distinct names for the fields present in the
+header. The field names have case as suggested by HTTP spec, and the
+names are returned in the recommended "Good Practice" order.
+
+In scalar context return the number of distinct field names.
+
+=item $h->scan( \&process_header_field )
+
+Apply a subroutine to each header field in turn. The callback routine
+is called with two parameters; the name of the field and a single
+value (a string). If a header field is multi-valued, then the
+routine is called once for each value. The field name passed to the
+callback routine has case as suggested by HTTP spec, and the headers
+will be visited in the recommended "Good Practice" order.
+
+Any return values of the callback routine are ignored. The loop can
+be broken by raising an exception (C<die>), but the caller of scan()
+would have to trap the exception itself.
+
+=item $h->as_string
+
+=item $h->as_string( $eol )
+
+Return the header fields as a formatted MIME header. Since it
+internally uses the C<scan> method to build the string, the result
+will use case as suggested by HTTP spec, and it will follow
+recommended "Good Practice" of ordering the header fields. Long header
+values are not folded.
+
+The optional $eol parameter specifies the line ending sequence to
+use. The default is "\n". Embedded "\n" characters in header field
+values will be substituted with this line ending sequence.
+
+=back
+
+=head1 CONVENIENCE METHODS
+
+The most frequently used headers can also be accessed through the
+following convenience methods. Most of these methods can both be used to read
+and to set the value of a header. The header value is set if you pass
+an argument to the method. The old header value is always returned.
+If the given header did not exist then C<undef> is returned.
+
+Methods that deal with dates/times always convert their value to system
+time (seconds since Jan 1, 1970) and they also expect this kind of
+value when the header value is set.
+
+=over 4
+
+=item $h->date
+
+This header represents the date and time at which the message was
+originated. I<E.g.>:
+
+ $h->date(time); # set current date
+
+=item $h->expires
+
+This header gives the date and time after which the entity should be
+considered stale.
+
+=item $h->if_modified_since
+
+=item $h->if_unmodified_since
+
+These header fields are used to make a request conditional. If the requested
+resource has (or has not) been modified since the time specified in this field,
+then the server will return a C<304 Not Modified> response instead of
+the document itself.
+
+=item $h->last_modified
+
+This header indicates the date and time at which the resource was last
+modified. I<E.g.>:
+
+ # check if document is more than 1 hour old
+ if (my $last_mod = $h->last_modified) {
+ if ($last_mod < time - 60*60) {
+ ...
+ }
+ }
+
+=item $h->content_type
+
+The Content-Type header field indicates the media type of the message
+content. I<E.g.>:
+
+ $h->content_type('text/html');
+
+The value returned will be converted to lower case, and potential
+parameters will be chopped off and returned as a separate value if in
+an array context. If there is no such header field, then the empty
+string is returned. This makes it safe to do the following:
+
+ if ($h->content_type eq 'text/html') {
+ # we enter this place even if the real header value happens to
+ # be 'TEXT/HTML; version=3.0'
+ ...
+ }
+
+=item $h->content_type_charset
+
+Returns the upper-cased charset specified in the Content-Type header. In list
+context return the lower-cased bare content type followed by the upper-cased
+charset. Both values will be C<undef> if not specified in the header.
+
+=item $h->content_is_text
+
+Returns TRUE if the Content-Type header field indicate that the
+content is textual.
+
+=item $h->content_is_html
+
+Returns TRUE if the Content-Type header field indicate that the
+content is some kind of HTML (including XHTML). This method can't be
+used to set Content-Type.
+
+=item $h->content_is_xhtml
+
+Returns TRUE if the Content-Type header field indicate that the
+content is XHTML. This method can't be used to set Content-Type.
+
+=item $h->content_is_xml
+
+Returns TRUE if the Content-Type header field indicate that the
+content is XML. This method can't be used to set Content-Type.
+
+=item $h->content_encoding
+
+The Content-Encoding header field is used as a modifier to the
+media type. When present, its value indicates what additional
+encoding mechanism has been applied to the resource.
+
+=item $h->content_length
+
+A decimal number indicating the size in bytes of the message content.
+
+=item $h->content_language
+
+The natural language(s) of the intended audience for the message
+content. The value is one or more language tags as defined by RFC
+1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
+way it is written in the US.
+
+=item $h->title
+
+The title of the document. In libwww-perl this header will be
+initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
+of HTML documents. I<This header is no longer part of the HTTP
+standard.>
+
+=item $h->user_agent
+
+This header field is used in request messages and contains information
+about the user agent originating the request. I<E.g.>:
+
+ $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
+
+=item $h->server
+
+The server header field contains information about the software being
+used by the originating server program handling the request.
+
+=item $h->from
+
+This header should contain an Internet e-mail address for the human
+user who controls the requesting user agent. The address should be
+machine-usable, as defined by RFC822. E.g.:
+
+ $h->from('King Kong <king@kong.com>');
+
+I<This header is no longer part of the HTTP standard.>
+
+=item $h->referer
+
+Used to specify the address (URI) of the document from which the
+requested resource address was obtained.
+
+The "Free On-line Dictionary of Computing" as this to say about the
+word I<referer>:
+
+ <World-Wide Web> A misspelling of "referrer" which
+ somehow made it into the {HTTP} standard. A given {web
+ page}'s referer (sic) is the {URL} of whatever web page
+ contains the link that the user followed to the current
+ page. Most browsers pass this information as part of a
+ request.
+
+ (1998-10-19)
+
+By popular demand C<referrer> exists as an alias for this method so you
+can avoid this misspelling in your programs and still send the right
+thing on the wire.
+
+When setting the referrer, this method removes the fragment from the
+given URI if it is present, as mandated by RFC2616. Note that
+the removal does I<not> happen automatically if using the header(),
+push_header() or init_header() methods to set the referrer.
+
+=item $h->www_authenticate
+
+This header must be included as part of a C<401 Unauthorized> response.
+The field value consist of a challenge that indicates the
+authentication scheme and parameters applicable to the requested URI.
+
+=item $h->proxy_authenticate
+
+This header must be included in a C<407 Proxy Authentication Required>
+response.
+
+=item $h->authorization
+
+=item $h->proxy_authorization
+
+A user agent that wishes to authenticate itself with a server or a
+proxy, may do so by including these headers.
+
+=item $h->authorization_basic
+
+This method is used to get or set an authorization header that use the
+"Basic Authentication Scheme". In array context it will return two
+values; the user name and the password. In scalar context it will
+return I<"uname:password"> as a single string value.
+
+When used to set the header value, it expects two arguments. I<E.g.>:
+
+ $h->authorization_basic($uname, $password);
+
+The method will croak if the $uname contains a colon ':'.
+
+=item $h->proxy_authorization_basic
+
+Same as authorization_basic() but will set the "Proxy-Authorization"
+header instead.
+
+=back
+
+=head1 NON-CANONICALIZED FIELD NAMES
+
+The header field name spelling is normally canonicalized including the
+'_' to '-' translation. There are some application where this is not
+appropriate. Prefixing field names with ':' allow you to force a
+specific spelling. For example if you really want a header field name
+to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
+this:
+
+ $h->header(":foo_bar" => 1);
+
+These field names are returned with the ':' intact for
+$h->header_field_names and the $h->scan callback, but the colons do
+not show in $h->as_string.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2005 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
--- /dev/null
+package HTTP::Headers::Auth;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "6.00";
+
+use HTTP::Headers;
+
+package HTTP::Headers;
+
+BEGIN {
+ # we provide a new (and better) implementations below
+ undef(&www_authenticate);
+ undef(&proxy_authenticate);
+}
+
+require HTTP::Headers::Util;
+
+sub _parse_authenticate
+{
+ my @ret;
+ for (HTTP::Headers::Util::split_header_words(@_)) {
+ if (!defined($_->[1])) {
+ # this is a new auth scheme
+ push(@ret, shift(@$_) => {});
+ shift @$_;
+ }
+ if (@ret) {
+ # this a new parameter pair for the last auth scheme
+ while (@$_) {
+ my $k = shift @$_;
+ my $v = shift @$_;
+ $ret[-1]{$k} = $v;
+ }
+ }
+ else {
+ # something wrong, parameter pair without any scheme seen
+ # IGNORE
+ }
+ }
+ @ret;
+}
+
+sub _authenticate
+{
+ my $self = shift;
+ my $header = shift;
+ my @old = $self->_header($header);
+ if (@_) {
+ $self->remove_header($header);
+ my @new = @_;
+ while (@new) {
+ my $a_scheme = shift(@new);
+ if ($a_scheme =~ /\s/) {
+ # assume complete valid value, pass it through
+ $self->push_header($header, $a_scheme);
+ }
+ else {
+ my @param;
+ if (@new) {
+ my $p = $new[0];
+ if (ref($p) eq "ARRAY") {
+ @param = @$p;
+ shift(@new);
+ }
+ elsif (ref($p) eq "HASH") {
+ @param = %$p;
+ shift(@new);
+ }
+ }
+ my $val = ucfirst(lc($a_scheme));
+ if (@param) {
+ my $sep = " ";
+ while (@param) {
+ my $k = shift @param;
+ my $v = shift @param;
+ if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
+ # must quote the value
+ $v =~ s,([\\\"]),\\$1,g;
+ $v = qq("$v");
+ }
+ $val .= "$sep$k=$v";
+ $sep = ", ";
+ }
+ }
+ $self->push_header($header, $val);
+ }
+ }
+ }
+ return unless defined wantarray;
+ wantarray ? _parse_authenticate(@old) : join(", ", @old);
+}
+
+
+sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) }
+sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) }
+
+1;
--- /dev/null
+package HTTP::Headers::ETag;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "6.00";
+
+require HTTP::Date;
+
+require HTTP::Headers;
+package HTTP::Headers;
+
+sub _etags
+{
+ my $self = shift;
+ my $header = shift;
+ my @old = _split_etag_list($self->_header($header));
+ if (@_) {
+ $self->_header($header => join(", ", _split_etag_list(@_)));
+ }
+ wantarray ? @old : join(", ", @old);
+}
+
+sub etag { shift->_etags("ETag", @_); }
+sub if_match { shift->_etags("If-Match", @_); }
+sub if_none_match { shift->_etags("If-None-Match", @_); }
+
+sub if_range {
+ # Either a date or an entity-tag
+ my $self = shift;
+ my @old = $self->_header("If-Range");
+ if (@_) {
+ my $new = shift;
+ if (!defined $new) {
+ $self->remove_header("If-Range");
+ }
+ elsif ($new =~ /^\d+$/) {
+ $self->_date_header("If-Range", $new);
+ }
+ else {
+ $self->_etags("If-Range", $new);
+ }
+ }
+ return unless defined(wantarray);
+ for (@old) {
+ my $t = HTTP::Date::str2time($_);
+ $_ = $t if $t;
+ }
+ wantarray ? @old : join(", ", @old);
+}
+
+
+# Split a list of entity tag values. The return value is a list
+# consisting of one element per entity tag. Suitable for parsing
+# headers like C<If-Match>, C<If-None-Match>. You might even want to
+# use it on C<ETag> and C<If-Range> entity tag values, because it will
+# normalize them to the common form.
+#
+# entity-tag = [ weak ] opaque-tag
+# weak = "W/"
+# opaque-tag = quoted-string
+
+
+sub _split_etag_list
+{
+ my(@val) = @_;
+ my @res;
+ for (@val) {
+ while (length) {
+ my $weak = "";
+ $weak = "W/" if s,^\s*[wW]/,,;
+ my $etag = "";
+ if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
+ push(@res, "$weak$1");
+ }
+ elsif (s/^\s*,//) {
+ push(@res, qq(W/"")) if $weak;
+ }
+ elsif (s/^\s*([^,\s]+)//) {
+ $etag = $1;
+ $etag =~ s/([\"\\])/\\$1/g;
+ push(@res, qq($weak"$etag"));
+ }
+ elsif (s/^\s+// || !length) {
+ push(@res, qq(W/"")) if $weak;
+ }
+ else {
+ die "This should not happen: '$_'";
+ }
+ }
+ }
+ @res;
+}
+
+1;
--- /dev/null
+package HTTP::Headers::Util;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT_OK);
+
+$VERSION = "6.03";
+
+require Exporter;
+@ISA=qw(Exporter);
+
+@EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
+
+
+
+sub split_header_words {
+ my @res = &_split_header_words;
+ for my $arr (@res) {
+ for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
+ $arr->[$i] = lc($arr->[$i]);
+ }
+ }
+ return @res;
+}
+
+sub _split_header_words
+{
+ my(@val) = @_;
+ my @res;
+ for (@val) {
+ my @cur;
+ while (length) {
+ if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
+ push(@cur, $1);
+ # a quoted value
+ if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
+ my $val = $1;
+ $val =~ s/\\(.)/$1/g;
+ push(@cur, $val);
+ # some unquoted value
+ }
+ elsif (s/^\s*=\s*([^;,\s]*)//) {
+ my $val = $1;
+ $val =~ s/\s+$//;
+ push(@cur, $val);
+ # no value, a lone token
+ }
+ else {
+ push(@cur, undef);
+ }
+ }
+ elsif (s/^\s*,//) {
+ push(@res, [@cur]) if @cur;
+ @cur = ();
+ }
+ elsif (s/^\s*;// || s/^\s+//) {
+ # continue
+ }
+ else {
+ die "This should not happen: '$_'";
+ }
+ }
+ push(@res, \@cur) if @cur;
+ }
+ @res;
+}
+
+
+sub join_header_words
+{
+ @_ = ([@_]) if @_ && !ref($_[0]);
+ my @res;
+ for (@_) {
+ my @cur = @$_;
+ my @attr;
+ while (@cur) {
+ my $k = shift @cur;
+ my $v = shift @cur;
+ if (defined $v) {
+ if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
+ $v =~ s/([\"\\])/\\$1/g; # escape " and \
+ $k .= qq(="$v");
+ }
+ else {
+ # token
+ $k .= "=$v";
+ }
+ }
+ push(@attr, $k);
+ }
+ push(@res, join("; ", @attr)) if @attr;
+ }
+ join(", ", @res);
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Headers::Util - Header value parsing utility functions
+
+=head1 SYNOPSIS
+
+ use HTTP::Headers::Util qw(split_header_words);
+ @values = split_header_words($h->header("Content-Type"));
+
+=head1 DESCRIPTION
+
+This module provides a few functions that helps parsing and
+construction of valid HTTP header values. None of the functions are
+exported by default.
+
+The following functions are available:
+
+=over 4
+
+
+=item split_header_words( @header_values )
+
+This function will parse the header values given as argument into a
+list of anonymous arrays containing key/value pairs. The function
+knows how to deal with ",", ";" and "=" as well as quoted values after
+"=". A list of space separated tokens are parsed as if they were
+separated by ";".
+
+If the @header_values passed as argument contains multiple values,
+then they are treated as if they were a single value separated by
+comma ",".
+
+This means that this function is useful for parsing header fields that
+follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
+the requirement for tokens).
+
+ headers = #header
+ header = (token | parameter) *( [";"] (token | parameter))
+
+ token = 1*<any CHAR except CTLs or separators>
+ separators = "(" | ")" | "<" | ">" | "@"
+ | "," | ";" | ":" | "\" | <">
+ | "/" | "[" | "]" | "?" | "="
+ | "{" | "}" | SP | HT
+
+ quoted-string = ( <"> *(qdtext | quoted-pair ) <"> )
+ qdtext = <any TEXT except <">>
+ quoted-pair = "\" CHAR
+
+ parameter = attribute "=" value
+ attribute = token
+ value = token | quoted-string
+
+Each I<header> is represented by an anonymous array of key/value
+pairs. The keys will be all be forced to lower case.
+The value for a simple token (not part of a parameter) is C<undef>.
+Syntactically incorrect headers will not necessarily be parsed as you
+would want.
+
+This is easier to describe with some examples:
+
+ split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
+ split_header_words('text/html; charset="iso-8859-1"');
+ split_header_words('Basic realm="\\"foo\\\\bar\\""');
+
+will return
+
+ [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
+ ['text/html' => undef, charset => 'iso-8859-1']
+ [basic => undef, realm => "\"foo\\bar\""]
+
+If you don't want the function to convert tokens and attribute keys to
+lower case you can call it as C<_split_header_words> instead (with a
+leading underscore).
+
+=item join_header_words( @arrays )
+
+This will do the opposite of the conversion done by split_header_words().
+It takes a list of anonymous arrays as arguments (or a list of
+key/value pairs) and produces a single header value. Attribute values
+are quoted if needed.
+
+Example:
+
+ join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
+ join_header_words("text/plain" => undef, charset => "iso-8859/1");
+
+will both return the string:
+
+ text/plain; charset="iso-8859/1"
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1997-1998, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
--- /dev/null
+package HTTP::Message;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+$VERSION = "6.03";
+
+require HTTP::Headers;
+require Carp;
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
+eval "require $HTTP::URI_CLASS"; die $@ if $@;
+
+*_utf8_downgrade = defined(&utf8::downgrade) ?
+ sub {
+ utf8::downgrade($_[0], 1) or
+ Carp::croak("HTTP::Message content must be bytes")
+ }
+ :
+ sub {
+ };
+
+sub new
+{
+ my($class, $header, $content) = @_;
+ if (defined $header) {
+ Carp::croak("Bad header argument") unless ref $header;
+ if (ref($header) eq "ARRAY") {
+ $header = HTTP::Headers->new(@$header);
+ }
+ else {
+ $header = $header->clone;
+ }
+ }
+ else {
+ $header = HTTP::Headers->new;
+ }
+ if (defined $content) {
+ _utf8_downgrade($content);
+ }
+ else {
+ $content = '';
+ }
+
+ bless {
+ '_headers' => $header,
+ '_content' => $content,
+ }, $class;
+}
+
+
+sub parse
+{
+ my($class, $str) = @_;
+
+ my @hdr;
+ while (1) {
+ if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
+ push(@hdr, $1, $2);
+ $hdr[-1] =~ s/\r\z//;
+ }
+ elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
+ $hdr[-1] .= "\n$1";
+ $hdr[-1] =~ s/\r\z//;
+ }
+ else {
+ $str =~ s/^\r?\n//;
+ last;
+ }
+ }
+ local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+ new($class, \@hdr, $str);
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $clone = HTTP::Message->new($self->headers,
+ $self->content);
+ $clone->protocol($self->protocol);
+ $clone;
+}
+
+
+sub clear {
+ my $self = shift;
+ $self->{_headers}->clear;
+ $self->content("");
+ delete $self->{_parts};
+ return;
+}
+
+
+sub protocol {
+ shift->_elem('_protocol', @_);
+}
+
+sub headers {
+ my $self = shift;
+
+ # recalculation of _content might change headers, so we
+ # need to force it now
+ $self->_content unless exists $self->{_content};
+
+ $self->{_headers};
+}
+
+sub headers_as_string {
+ shift->headers->as_string(@_);
+}
+
+
+sub content {
+
+ my $self = $_[0];
+ if (defined(wantarray)) {
+ $self->_content unless exists $self->{_content};
+ my $old = $self->{_content};
+ $old = $$old if ref($old) eq "SCALAR";
+ &_set_content if @_ > 1;
+ return $old;
+ }
+
+ if (@_ > 1) {
+ &_set_content;
+ }
+ else {
+ Carp::carp("Useless content call in void context") if $^W;
+ }
+}
+
+
+sub _set_content {
+ my $self = $_[0];
+ _utf8_downgrade($_[1]);
+ if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
+ ${$self->{_content}} = $_[1];
+ }
+ else {
+ die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
+ $self->{_content} = $_[1];
+ delete $self->{_content_ref};
+ }
+ delete $self->{_parts} unless $_[2];
+}
+
+
+sub add_content
+{
+ my $self = shift;
+ $self->_content unless exists $self->{_content};
+ my $chunkref = \$_[0];
+ $chunkref = $$chunkref if ref($$chunkref); # legacy
+
+ _utf8_downgrade($$chunkref);
+
+ my $ref = ref($self->{_content});
+ if (!$ref) {
+ $self->{_content} .= $$chunkref;
+ }
+ elsif ($ref eq "SCALAR") {
+ ${$self->{_content}} .= $$chunkref;
+ }
+ else {
+ Carp::croak("Can't append to $ref content");
+ }
+ delete $self->{_parts};
+}
+
+sub add_content_utf8 {
+ my($self, $buf) = @_;
+ utf8::upgrade($buf);
+ utf8::encode($buf);
+ $self->add_content($buf);
+}
+
+sub content_ref
+{
+ my $self = shift;
+ $self->_content unless exists $self->{_content};
+ delete $self->{_parts};
+ my $old = \$self->{_content};
+ my $old_cref = $self->{_content_ref};
+ if (@_) {
+ my $new = shift;
+ Carp::croak("Setting content_ref to a non-ref") unless ref($new);
+ delete $self->{_content}; # avoid modifying $$old
+ $self->{_content} = $new;
+ $self->{_content_ref}++;
+ }
+ $old = $$old if $old_cref;
+ return $old;
+}
+
+
+sub content_charset
+{
+ my $self = shift;
+ if (my $charset = $self->content_type_charset) {
+ return $charset;
+ }
+
+ # time to start guessing
+ my $cref = $self->decoded_content(ref => 1, charset => "none");
+
+ # Unicode BOM
+ for ($$cref) {
+ return "UTF-8" if /^\xEF\xBB\xBF/;
+ return "UTF-32-LE" if /^\xFF\xFE\x00\x00/;
+ return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
+ return "UTF-16-LE" if /^\xFF\xFE/;
+ return "UTF-16-BE" if /^\xFE\xFF/;
+ }
+
+ if ($self->content_is_xml) {
+ # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
+ # XML entity not accompanied by external encoding information and not
+ # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
+ # in which the first characters must be '<?xml'
+ for ($$cref) {
+ return "UTF-32-BE" if /^\x00\x00\x00</;
+ return "UTF-32-LE" if /^<\x00\x00\x00/;
+ return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
+ return "UTF-16-LE" if /^(?:\s\x00)*<\x00/;
+ if (/^\s*(<\?xml[^\x00]*?\?>)/) {
+ if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
+ my $enc = $2;
+ $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
+ return $enc if $enc;
+ }
+ }
+ }
+ return "UTF-8";
+ }
+ elsif ($self->content_is_html) {
+ # look for <META charset="..."> or <META content="...">
+ # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
+ my $charset;
+ require HTML::Parser;
+ my $p = HTML::Parser->new(
+ start_h => [sub {
+ my($tag, $attr, $self) = @_;
+ $charset = $attr->{charset};
+ unless ($charset) {
+ # look at $attr->{content} ...
+ if (my $c = $attr->{content}) {
+ require HTTP::Headers::Util;
+ my @v = HTTP::Headers::Util::split_header_words($c);
+ return unless @v;
+ my($ct, undef, %ct_param) = @{$v[0]};
+ $charset = $ct_param{charset};
+ }
+ return unless $charset;
+ }
+ if ($charset =~ /^utf-?16/i) {
+ # converted document, assume UTF-8
+ $charset = "UTF-8";
+ }
+ $self->eof;
+ }, "tagname, attr, self"],
+ report_tags => [qw(meta)],
+ utf8_mode => 1,
+ );
+ $p->parse($$cref);
+ return $charset if $charset;
+ }
+ if ($self->content_type =~ /^text\//) {
+ for ($$cref) {
+ if (length) {
+ return "US-ASCII" unless /[\x80-\xFF]/;
+ require Encode;
+ eval {
+ Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
+ };
+ return "UTF-8" unless $@;
+ return "ISO-8859-1";
+ }
+ }
+ }
+
+ return undef;
+}
+
+
+sub decoded_content
+{
+ my($self, %opt) = @_;
+ my $content_ref;
+ my $content_ref_iscopy;
+
+ eval {
+ $content_ref = $self->content_ref;
+ die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
+
+ if (my $h = $self->header("Content-Encoding")) {
+ $h =~ s/^\s+//;
+ $h =~ s/\s+$//;
+ for my $ce (reverse split(/\s*,\s*/, lc($h))) {
+ next unless $ce;
+ next if $ce eq "identity";
+ if ($ce eq "gzip" || $ce eq "x-gzip") {
+ require IO::Uncompress::Gunzip;
+ my $output;
+ IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
+ or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+ $content_ref = \$output;
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
+ require IO::Uncompress::Bunzip2;
+ my $output;
+ IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
+ or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
+ $content_ref = \$output;
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "deflate") {
+ require IO::Uncompress::Inflate;
+ my $output;
+ my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
+ my $error = $IO::Uncompress::Inflate::InflateError;
+ unless ($status) {
+ # "Content-Encoding: deflate" is supposed to mean the
+ # "zlib" format of RFC 1950, but Microsoft got that
+ # wrong, so some servers sends the raw compressed
+ # "deflate" data. This tries to inflate this format.
+ $output = undef;
+ require IO::Uncompress::RawInflate;
+ unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
+ $self->push_header("Client-Warning" =>
+ "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
+ $output = undef;
+ }
+ }
+ die "Can't inflate content: $error" unless defined $output;
+ $content_ref = \$output;
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "compress" || $ce eq "x-compress") {
+ die "Can't uncompress content";
+ }
+ elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
+ require MIME::Base64;
+ $content_ref = \MIME::Base64::decode($$content_ref);
+ $content_ref_iscopy++;
+ }
+ elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
+ require MIME::QuotedPrint;
+ $content_ref = \MIME::QuotedPrint::decode($$content_ref);
+ $content_ref_iscopy++;
+ }
+ else {
+ die "Don't know how to decode Content-Encoding '$ce'";
+ }
+ }
+ }
+
+ if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
+ my $charset = lc(
+ $opt{charset} ||
+ $self->content_type_charset ||
+ $opt{default_charset} ||
+ $self->content_charset ||
+ "ISO-8859-1"
+ );
+ if ($charset eq "none") {
+ # leave it asis
+ }
+ elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") {
+ if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) {
+ unless ($content_ref_iscopy) {
+ my $copy = $$content_ref;
+ $content_ref = \$copy;
+ $content_ref_iscopy++;
+ }
+ utf8::upgrade($$content_ref);
+ }
+ }
+ else {
+ require Encode;
+ eval {
+ $content_ref = \Encode::decode($charset, $$content_ref,
+ ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
+ };
+ if ($@) {
+ my $retried;
+ if ($@ =~ /^Unknown encoding/) {
+ my $alt_charset = lc($opt{alt_charset} || "");
+ if ($alt_charset && $charset ne $alt_charset) {
+ # Retry decoding with the alternative charset
+ $content_ref = \Encode::decode($alt_charset, $$content_ref,
+ ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
+ unless $alt_charset eq "none";
+ $retried++;
+ }
+ }
+ die unless $retried;
+ }
+ die "Encode::decode() returned undef improperly" unless defined $$content_ref;
+ if ($is_xml) {
+ # Get rid of the XML encoding declaration if present
+ $$content_ref =~ s/^\x{FEFF}//;
+ if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
+ substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
+ }
+ }
+ }
+ }
+ };
+ if ($@) {
+ Carp::croak($@) if $opt{raise_error};
+ return undef;
+ }
+
+ return $opt{ref} ? $content_ref : $$content_ref;
+}
+
+
+sub decodable
+{
+ # should match the Content-Encoding values that decoded_content can deal with
+ my $self = shift;
+ my @enc;
+ # XXX preferably we should determine if the modules are available without loading
+ # them here
+ eval {
+ require IO::Uncompress::Gunzip;
+ push(@enc, "gzip", "x-gzip");
+ };
+ eval {
+ require IO::Uncompress::Inflate;
+ require IO::Uncompress::RawInflate;
+ push(@enc, "deflate");
+ };
+ eval {
+ require IO::Uncompress::Bunzip2;
+ push(@enc, "x-bzip2");
+ };
+ # we don't care about announcing the 'identity', 'base64' and
+ # 'quoted-printable' stuff
+ return wantarray ? @enc : join(", ", @enc);
+}
+
+
+sub decode
+{
+ my $self = shift;
+ return 1 unless $self->header("Content-Encoding");
+ if (defined(my $content = $self->decoded_content(charset => "none"))) {
+ $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
+ $self->content($content);
+ return 1;
+ }
+ return 0;
+}
+
+
+sub encode
+{
+ my($self, @enc) = @_;
+
+ Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
+ Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
+
+ return 1 unless @enc; # nothing to do
+
+ my $content = $self->content;
+ for my $encoding (@enc) {
+ if ($encoding eq "identity") {
+ # nothing to do
+ }
+ elsif ($encoding eq "base64") {
+ require MIME::Base64;
+ $content = MIME::Base64::encode($content);
+ }
+ elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
+ require IO::Compress::Gzip;
+ my $output;
+ IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
+ or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
+ $content = $output;
+ }
+ elsif ($encoding eq "deflate") {
+ require IO::Compress::Deflate;
+ my $output;
+ IO::Compress::Deflate::deflate(\$content, \$output)
+ or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
+ $content = $output;
+ }
+ elsif ($encoding eq "x-bzip2") {
+ require IO::Compress::Bzip2;
+ my $output;
+ IO::Compress::Bzip2::bzip2(\$content, \$output)
+ or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
+ $content = $output;
+ }
+ elsif ($encoding eq "rot13") { # for the fun of it
+ $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
+ }
+ else {
+ return 0;
+ }
+ }
+ my $h = $self->header("Content-Encoding");
+ unshift(@enc, $h) if $h;
+ $self->header("Content-Encoding", join(", ", @enc));
+ $self->remove_header("Content-Length", "Content-MD5");
+ $self->content($content);
+ return 1;
+}
+
+
+sub as_string
+{
+ my($self, $eol) = @_;
+ $eol = "\n" unless defined $eol;
+
+ # The calculation of content might update the headers
+ # so we need to do that first.
+ my $content = $self->content;
+
+ return join("", $self->{'_headers'}->as_string($eol),
+ $eol,
+ $content,
+ (@_ == 1 && length($content) &&
+ $content !~ /\n\z/) ? "\n" : "",
+ );
+}
+
+
+sub dump
+{
+ my($self, %opt) = @_;
+ my $content = $self->content;
+ my $chopped = 0;
+ if (!ref($content)) {
+ my $maxlen = $opt{maxlength};
+ $maxlen = 512 unless defined($maxlen);
+ if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
+ $chopped = length($content) - $maxlen;
+ $content = substr($content, 0, $maxlen) . "...";
+ }
+
+ $content =~ s/\\/\\\\/g;
+ $content =~ s/\t/\\t/g;
+ $content =~ s/\r/\\r/g;
+
+ # no need for 3 digits in escape for these
+ $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+
+ $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+ $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
+
+ # remaining whitespace
+ $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
+ $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
+ $content =~ s/\n\z/\\n/;
+
+ my $no_content = "(no content)";
+ if ($content eq $no_content) {
+ # escape our $no_content marker
+ $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
+ }
+ elsif ($content eq "") {
+ $content = "(no content)";
+ }
+ }
+
+ my @dump;
+ push(@dump, $opt{preheader}) if $opt{preheader};
+ push(@dump, $self->{_headers}->as_string, $content);
+ push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
+
+ my $dump = join("\n", @dump, "");
+ $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
+
+ print $dump unless defined wantarray;
+ return $dump;
+}
+
+
+sub parts {
+ my $self = shift;
+ if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
+ $self->_parts;
+ }
+ my $old = $self->{_parts};
+ if (@_) {
+ my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
+ my $ct = $self->content_type || "";
+ if ($ct =~ m,^message/,) {
+ Carp::croak("Only one part allowed for $ct content")
+ if @parts > 1;
+ }
+ elsif ($ct !~ m,^multipart/,) {
+ $self->remove_content_headers;
+ $self->content_type("multipart/mixed");
+ }
+ $self->{_parts} = \@parts;
+ _stale_content($self);
+ }
+ return @$old if wantarray;
+ return $old->[0];
+}
+
+sub add_part {
+ my $self = shift;
+ if (($self->content_type || "") !~ m,^multipart/,) {
+ my $p = HTTP::Message->new($self->remove_content_headers,
+ $self->content(""));
+ $self->content_type("multipart/mixed");
+ $self->{_parts} = [];
+ if ($p->headers->header_field_names || $p->content ne "") {
+ push(@{$self->{_parts}}, $p);
+ }
+ }
+ elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
+ $self->_parts;
+ }
+
+ push(@{$self->{_parts}}, @_);
+ _stale_content($self);
+ return;
+}
+
+sub _stale_content {
+ my $self = shift;
+ if (ref($self->{_content}) eq "SCALAR") {
+ # must recalculate now
+ $self->_content;
+ }
+ else {
+ # just invalidate cache
+ delete $self->{_content};
+ delete $self->{_content_ref};
+ }
+}
+
+
+# delegate all other method calls the the headers object.
+sub AUTOLOAD
+{
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+ # We create the function here so that it will not need to be
+ # autoloaded the next time.
+ no strict 'refs';
+ *$method = sub { shift->headers->$method(@_) };
+ goto &$method;
+}
+
+
+sub DESTROY {} # avoid AUTOLOADing it
+
+
+# Private method to access members in %$self
+sub _elem
+{
+ my $self = shift;
+ my $elem = shift;
+ my $old = $self->{$elem};
+ $self->{$elem} = $_[0] if @_;
+ return $old;
+}
+
+
+# Create private _parts attribute from current _content
+sub _parts {
+ my $self = shift;
+ my $ct = $self->content_type;
+ if ($ct =~ m,^multipart/,) {
+ require HTTP::Headers::Util;
+ my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
+ die "Assert" unless @h;
+ my %h = @{$h[0]};
+ if (defined(my $b = $h{boundary})) {
+ my $str = $self->content;
+ $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s;
+ if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
+ $self->{_parts} = [map HTTP::Message->parse($_),
+ split(/\r?\n--\Q$b\E\r?\n/, $str)]
+ }
+ }
+ }
+ elsif ($ct eq "message/http") {
+ require HTTP::Request;
+ require HTTP::Response;
+ my $content = $self->content;
+ my $class = ($content =~ m,^(HTTP/.*)\n,) ?
+ "HTTP::Response" : "HTTP::Request";
+ $self->{_parts} = [$class->parse($content)];
+ }
+ elsif ($ct =~ m,^message/,) {
+ $self->{_parts} = [ HTTP::Message->parse($self->content) ];
+ }
+
+ $self->{_parts} ||= [];
+}
+
+
+# Create private _content attribute from current _parts
+sub _content {
+ my $self = shift;
+ my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
+ if ($ct =~ m,^\s*message/,i) {
+ _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
+ return;
+ }
+
+ require HTTP::Headers::Util;
+ my @v = HTTP::Headers::Util::split_header_words($ct);
+ Carp::carp("Multiple Content-Type headers") if @v > 1;
+ @v = @{$v[0]};
+
+ my $boundary;
+ my $boundary_index;
+ for (my @tmp = @v; @tmp;) {
+ my($k, $v) = splice(@tmp, 0, 2);
+ if ($k eq "boundary") {
+ $boundary = $v;
+ $boundary_index = @v - @tmp - 1;
+ last;
+ }
+ }
+
+ my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
+
+ my $bno = 0;
+ $boundary = _boundary() unless defined $boundary;
+ CHECK_BOUNDARY:
+ {
+ for (@parts) {
+ if (index($_, $boundary) >= 0) {
+ # must have a better boundary
+ $boundary = _boundary(++$bno);
+ redo CHECK_BOUNDARY;
+ }
+ }
+ }
+
+ if ($boundary_index) {
+ $v[$boundary_index] = $boundary;
+ }
+ else {
+ push(@v, boundary => $boundary);
+ }
+
+ $ct = HTTP::Headers::Util::join_header_words(@v);
+ $self->{_headers}->header("Content-Type", $ct);
+
+ _set_content($self, "--$boundary$CRLF" .
+ join("$CRLF--$boundary$CRLF", @parts) .
+ "$CRLF--$boundary--$CRLF",
+ 1);
+}
+
+
+sub _boundary
+{
+ my $size = shift || return "xYzZY";
+ require MIME::Base64;
+ my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
+ $b =~ s/[\W]/X/g; # ensure alnum only
+ $b;
+}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Message - HTTP style message (base class)
+
+=head1 SYNOPSIS
+
+ use base 'HTTP::Message';
+
+=head1 DESCRIPTION
+
+An C<HTTP::Message> object contains some headers and a content body.
+The following methods are available:
+
+=over 4
+
+=item $mess = HTTP::Message->new
+
+=item $mess = HTTP::Message->new( $headers )
+
+=item $mess = HTTP::Message->new( $headers, $content )
+
+This constructs a new message object. Normally you would want
+construct C<HTTP::Request> or C<HTTP::Response> objects instead.
+
+The optional $header argument should be a reference to an
+C<HTTP::Headers> object or a plain array reference of key/value pairs.
+If an C<HTTP::Headers> object is provided then a copy of it will be
+embedded into the constructed message, i.e. it will not be owned and
+can be modified afterwards without affecting the message.
+
+The optional $content argument should be a string of bytes.
+
+=item $mess = HTTP::Message->parse( $str )
+
+This constructs a new message object by parsing the given string.
+
+=item $mess->headers
+
+Returns the embedded C<HTTP::Headers> object.
+
+=item $mess->headers_as_string
+
+=item $mess->headers_as_string( $eol )
+
+Call the as_string() method for the headers in the
+message. This will be the same as
+
+ $mess->headers->as_string
+
+but it will make your program a whole character shorter :-)
+
+=item $mess->content
+
+=item $mess->content( $bytes )
+
+The content() method sets the raw content if an argument is given. If no
+argument is given the content is not touched. In either case the
+original raw content is returned.
+
+Note that the content should be a string of bytes. Strings in perl
+can contain characters outside the range of a byte. The C<Encode>
+module can be used to turn such strings into a string of bytes.
+
+=item $mess->add_content( $bytes )
+
+The add_content() methods appends more data bytes to the end of the
+current content buffer.
+
+=item $mess->add_content_utf8( $string )
+
+The add_content_utf8() method appends the UTF-8 bytes representing the
+string to the end of the current content buffer.
+
+=item $mess->content_ref
+
+=item $mess->content_ref( \$bytes )
+
+The content_ref() method will return a reference to content buffer string.
+It can be more efficient to access the content this way if the content
+is huge, and it can even be used for direct manipulation of the content,
+for instance:
+
+ ${$res->content_ref} =~ s/\bfoo\b/bar/g;
+
+This example would modify the content buffer in-place.
+
+If an argument is passed it will setup the content to reference some
+external source. The content() and add_content() methods
+will automatically dereference scalar references passed this way. For
+other references content() will return the reference itself and
+add_content() will refuse to do anything.
+
+=item $mess->content_charset
+
+This returns the charset used by the content in the message. The
+charset is either found as the charset attribute of the
+C<Content-Type> header or by guessing.
+
+See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
+for details about how charset is determined.
+
+=item $mess->decoded_content( %options )
+
+Returns the content with any C<Content-Encoding> undone and for textual content
+the raw content encoded to Perl's Unicode strings. If the C<Content-Encoding>
+or C<charset> of the message is unknown this method will fail by returning
+C<undef>.
+
+The following options can be specified.
+
+=over
+
+=item C<charset>
+
+This override the charset parameter for text content. The value
+C<none> can used to suppress decoding of the charset.
+
+=item C<default_charset>
+
+This override the default charset guessed by content_charset() or
+if that fails "ISO-8859-1".
+
+=item C<alt_charset>
+
+If decoding fails because the charset specified in the Content-Type header
+isn't recognized by Perl's Encode module, then try decoding using this charset
+instead of failing. The C<alt_charset> might be specified as C<none> to simply
+return the string without any decoding of charset as alternative.
+
+=item C<charset_strict>
+
+Abort decoding if malformed characters is found in the content. By
+default you get the substitution character ("\x{FFFD}") in place of
+malformed characters.
+
+=item C<raise_error>
+
+If TRUE then raise an exception if not able to decode content. Reason
+might be that the specified C<Content-Encoding> or C<charset> is not
+supported. If this option is FALSE, then decoded_content() will return
+C<undef> on errors, but will still set $@.
+
+=item C<ref>
+
+If TRUE then a reference to decoded content is returned. This might
+be more efficient in cases where the decoded content is identical to
+the raw content as no data copying is required in this case.
+
+=back
+
+=item $mess->decodable
+
+=item HTTP::Message::decodable()
+
+This returns the encoding identifiers that decoded_content() can
+process. In scalar context returns a comma separated string of
+identifiers.
+
+This value is suitable for initializing the C<Accept-Encoding> request
+header field.
+
+=item $mess->decode
+
+This method tries to replace the content of the message with the
+decoded version and removes the C<Content-Encoding> header. Returns
+TRUE if successful and FALSE if not.
+
+If the message does not have a C<Content-Encoding> header this method
+does nothing and returns TRUE.
+
+Note that the content of the message is still bytes after this method
+has been called and you still need to call decoded_content() if you
+want to process its content as a string.
+
+=item $mess->encode( $encoding, ... )
+
+Apply the given encodings to the content of the message. Returns TRUE
+if successful. The "identity" (non-)encoding is always supported; other
+currently supported encodings, subject to availability of required
+additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
+
+A successful call to this function will set the C<Content-Encoding>
+header.
+
+Note that C<multipart/*> or C<message/*> messages can't be encoded and
+this method will croak if you try.
+
+=item $mess->parts
+
+=item $mess->parts( @parts )
+
+=item $mess->parts( \@parts )
+
+Messages can be composite, i.e. contain other messages. The composite
+messages have a content type of C<multipart/*> or C<message/*>. This
+method give access to the contained messages.
+
+The argumentless form will return a list of C<HTTP::Message> objects.
+If the content type of $msg is not C<multipart/*> or C<message/*> then
+this will return the empty list. In scalar context only the first
+object is returned. The returned message parts should be regarded as
+read-only (future versions of this library might make it possible
+to modify the parent by modifying the parts).
+
+If the content type of $msg is C<message/*> then there will only be
+one part returned.
+
+If the content type is C<message/http>, then the return value will be
+either an C<HTTP::Request> or an C<HTTP::Response> object.
+
+If a @parts argument is given, then the content of the message will be
+modified. The array reference form is provided so that an empty list
+can be provided. The @parts array should contain C<HTTP::Message>
+objects. The @parts objects are owned by $mess after this call and
+should not be modified or made part of other messages.
+
+When updating the message with this method and the old content type of
+$mess is not C<multipart/*> or C<message/*>, then the content type is
+set to C<multipart/mixed> and all other content headers are cleared.
+
+This method will croak if the content type is C<message/*> and more
+than one part is provided.
+
+=item $mess->add_part( $part )
+
+This will add a part to a message. The $part argument should be
+another C<HTTP::Message> object. If the previous content type of
+$mess is not C<multipart/*> then the old content (together with all
+content headers) will be made part #1 and the content type made
+C<multipart/mixed> before the new part is added. The $part object is
+owned by $mess after this call and should not be modified or made part
+of other messages.
+
+There is no return value.
+
+=item $mess->clear
+
+Will clear the headers and set the content to the empty string. There
+is no return value
+
+=item $mess->protocol
+
+=item $mess->protocol( $proto )
+
+Sets the HTTP protocol used for the message. The protocol() is a string
+like C<HTTP/1.0> or C<HTTP/1.1>.
+
+=item $mess->clone
+
+Returns a copy of the message object.
+
+=item $mess->as_string
+
+=item $mess->as_string( $eol )
+
+Returns the message formatted as a single string.
+
+The optional $eol parameter specifies the line ending sequence to use.
+The default is "\n". If no $eol is given then as_string will ensure
+that the returned string is newline terminated (even when the message
+content is not). No extra newline is appended if an explicit $eol is
+passed.
+
+=item $mess->dump( %opt )
+
+Returns the message formatted as a string. In void context print the string.
+
+This differs from C<< $mess->as_string >> in that it escapes the bytes
+of the content so that it's safe to print them and it limits how much
+content to print. The escapes syntax used is the same as for Perl's
+double quoted strings. If there is no content the string "(no
+content)" is shown in its place.
+
+Options to influence the output can be passed as key/value pairs. The
+following options are recognized:
+
+=over
+
+=item maxlength => $num
+
+How much of the content to show. The default is 512. Set this to 0
+for unlimited.
+
+If the content is longer then the string is chopped at the limit and
+the string "...\n(### more bytes not shown)" appended.
+
+=item prefix => $str
+
+A string that will be prefixed to each line of the dump.
+
+=back
+
+=back
+
+All methods unknown to C<HTTP::Message> itself are delegated to the
+C<HTTP::Headers> object that is part of every message. This allows
+convenient access to these methods. Refer to L<HTTP::Headers> for
+details of these methods:
+
+ $mess->header( $field => $val )
+ $mess->push_header( $field => $val )
+ $mess->init_header( $field => $val )
+ $mess->remove_header( $field )
+ $mess->remove_content_headers
+ $mess->header_field_names
+ $mess->scan( \&doit )
+
+ $mess->date
+ $mess->expires
+ $mess->if_modified_since
+ $mess->if_unmodified_since
+ $mess->last_modified
+ $mess->content_type
+ $mess->content_encoding
+ $mess->content_length
+ $mess->content_language
+ $mess->title
+ $mess->user_agent
+ $mess->server
+ $mess->from
+ $mess->referer
+ $mess->www_authenticate
+ $mess->authorization
+ $mess->proxy_authorization
+ $mess->authorization_basic
+ $mess->proxy_authorization_basic
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
--- /dev/null
+package HTTP::Request;
+
+require HTTP::Message;
+@ISA = qw(HTTP::Message);
+$VERSION = "6.00";
+
+use strict;
+
+
+
+sub new
+{
+ my($class, $method, $uri, $header, $content) = @_;
+ my $self = $class->SUPER::new($header, $content);
+ $self->method($method);
+ $self->uri($uri);
+ $self;
+}
+
+
+sub parse
+{
+ my($class, $str) = @_;
+ my $request_line;
+ if ($str =~ s/^(.*)\n//) {
+ $request_line = $1;
+ }
+ else {
+ $request_line = $str;
+ $str = "";
+ }
+
+ my $self = $class->SUPER::parse($str);
+ my($method, $uri, $protocol) = split(' ', $request_line);
+ $self->method($method) if defined($method);
+ $self->uri($uri) if defined($uri);
+ $self->protocol($protocol) if $protocol;
+ $self;
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $clone = bless $self->SUPER::clone, ref($self);
+ $clone->method($self->method);
+ $clone->uri($self->uri);
+ $clone;
+}
+
+
+sub method
+{
+ shift->_elem('_method', @_);
+}
+
+
+sub uri
+{
+ my $self = shift;
+ my $old = $self->{'_uri'};
+ if (@_) {
+ my $uri = shift;
+ if (!defined $uri) {
+ # that's ok
+ }
+ elsif (ref $uri) {
+ Carp::croak("A URI can't be a " . ref($uri) . " reference")
+ if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
+ Carp::croak("Can't use a " . ref($uri) . " object as a URI")
+ unless $uri->can('scheme');
+ $uri = $uri->clone;
+ unless ($HTTP::URI_CLASS eq "URI") {
+ # Argh!! Hate this... old LWP legacy!
+ eval { local $SIG{__DIE__}; $uri = $uri->abs; };
+ die $@ if $@ && $@ !~ /Missing base argument/;
+ }
+ }
+ else {
+ $uri = $HTTP::URI_CLASS->new($uri);
+ }
+ $self->{'_uri'} = $uri;
+ delete $self->{'_uri_canonical'};
+ }
+ $old;
+}
+
+*url = \&uri; # legacy
+
+sub uri_canonical
+{
+ my $self = shift;
+ return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
+}
+
+
+sub accept_decodable
+{
+ my $self = shift;
+ $self->header("Accept-Encoding", scalar($self->decodable));
+}
+
+sub as_string
+{
+ my $self = shift;
+ my($eol) = @_;
+ $eol = "\n" unless defined $eol;
+
+ my $req_line = $self->method || "-";
+ my $uri = $self->uri;
+ $uri = (defined $uri) ? $uri->as_string : "-";
+ $req_line .= " $uri";
+ my $proto = $self->protocol;
+ $req_line .= " $proto" if $proto;
+
+ return join($eol, $req_line, $self->SUPER::as_string(@_));
+}
+
+sub dump
+{
+ my $self = shift;
+ my @pre = ($self->method || "-", $self->uri || "-");
+ if (my $prot = $self->protocol) {
+ push(@pre, $prot);
+ }
+
+ return $self->SUPER::dump(
+ preheader => join(" ", @pre),
+ @_,
+ );
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request - HTTP style request message
+
+=head1 SYNOPSIS
+
+ require HTTP::Request;
+ $request = HTTP::Request->new(GET => 'http://www.example.com/');
+
+and usually used like this:
+
+ $ua = LWP::UserAgent->new;
+ $response = $ua->request($request);
+
+=head1 DESCRIPTION
+
+C<HTTP::Request> is a class encapsulating HTTP style requests,
+consisting of a request line, some headers, and a content body. Note
+that the LWP library uses HTTP style requests even for non-HTTP
+protocols. Instances of this class are usually passed to the
+request() method of an C<LWP::UserAgent> object.
+
+C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
+inherits its methods. The following additional methods are available:
+
+=over 4
+
+=item $r = HTTP::Request->new( $method, $uri )
+
+=item $r = HTTP::Request->new( $method, $uri, $header )
+
+=item $r = HTTP::Request->new( $method, $uri, $header, $content )
+
+Constructs a new C<HTTP::Request> object describing a request on the
+object $uri using method $method. The $method argument must be a
+string. The $uri argument can be either a string, or a reference to a
+C<URI> object. The optional $header argument should be a reference to
+an C<HTTP::Headers> object or a plain array reference of key/value
+pairs. The optional $content argument should be a string of bytes.
+
+=item $r = HTTP::Request->parse( $str )
+
+This constructs a new request object by parsing the given string.
+
+=item $r->method
+
+=item $r->method( $val )
+
+This is used to get/set the method attribute. The method should be a
+short string like "GET", "HEAD", "PUT" or "POST".
+
+=item $r->uri
+
+=item $r->uri( $val )
+
+This is used to get/set the uri attribute. The $val can be a
+reference to a URI object or a plain string. If a string is given,
+then it should be parseable as an absolute URI.
+
+=item $r->header( $field )
+
+=item $r->header( $field => $value )
+
+This is used to get/set header values and it is inherited from
+C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
+details and other similar methods that can be used to access the
+headers.
+
+=item $r->accept_decodable
+
+This will set the C<Accept-Encoding> header to the list of encodings
+that decoded_content() can decode.
+
+=item $r->content
+
+=item $r->content( $bytes )
+
+This is used to get/set the content and it is inherited from the
+C<HTTP::Message> base class. See L<HTTP::Message> for details and
+other methods that can be used to access the content.
+
+Note that the content should be a string of bytes. Strings in perl
+can contain characters outside the range of a byte. The C<Encode>
+module can be used to turn such strings into a string of bytes.
+
+=item $r->as_string
+
+=item $r->as_string( $eol )
+
+Method returning a textual representation of the request.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
+L<HTTP::Response>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
--- /dev/null
+package HTTP::Request::Common;
+
+use strict;
+use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
+
+$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT =qw(GET HEAD PUT POST);
+@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
+
+require HTTP::Request;
+use Carp();
+
+$VERSION = "6.03";
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+
+sub GET { _simple_req('GET', @_); }
+sub HEAD { _simple_req('HEAD', @_); }
+sub PUT { _simple_req('PUT' , @_); }
+sub DELETE { _simple_req('DELETE', @_); }
+
+sub POST
+{
+ my $url = shift;
+ my $req = HTTP::Request->new(POST => $url);
+ my $content;
+ $content = shift if @_ and ref $_[0];
+ my($k, $v);
+ while (($k,$v) = splice(@_, 0, 2)) {
+ if (lc($k) eq 'content') {
+ $content = $v;
+ }
+ else {
+ $req->push_header($k, $v);
+ }
+ }
+ my $ct = $req->header('Content-Type');
+ unless ($ct) {
+ $ct = 'application/x-www-form-urlencoded';
+ }
+ elsif ($ct eq 'form-data') {
+ $ct = 'multipart/form-data';
+ }
+
+ if (ref $content) {
+ if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
+ require HTTP::Headers::Util;
+ my @v = HTTP::Headers::Util::split_header_words($ct);
+ Carp::carp("Multiple Content-Type headers") if @v > 1;
+ @v = @{$v[0]};
+
+ my $boundary;
+ my $boundary_index;
+ for (my @tmp = @v; @tmp;) {
+ my($k, $v) = splice(@tmp, 0, 2);
+ if ($k eq "boundary") {
+ $boundary = $v;
+ $boundary_index = @v - @tmp - 1;
+ last;
+ }
+ }
+
+ ($content, $boundary) = form_data($content, $boundary, $req);
+
+ if ($boundary_index) {
+ $v[$boundary_index] = $boundary;
+ }
+ else {
+ push(@v, boundary => $boundary);
+ }
+
+ $ct = HTTP::Headers::Util::join_header_words(@v);
+ }
+ else {
+ # We use a temporary URI object to format
+ # the application/x-www-form-urlencoded content.
+ require URI;
+ my $url = URI->new('http:');
+ $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
+ $content = $url->query;
+
+ # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A')
+ $content =~ s/(?<!%0D)%0A/%0D%0A/g;
+ }
+ }
+
+ $req->header('Content-Type' => $ct); # might be redundant
+ if (defined($content)) {
+ $req->header('Content-Length' =>
+ length($content)) unless ref($content);
+ $req->content($content);
+ }
+ else {
+ $req->header('Content-Length' => 0);
+ }
+ $req;
+}
+
+
+sub _simple_req
+{
+ my($method, $url) = splice(@_, 0, 2);
+ my $req = HTTP::Request->new($method => $url);
+ my($k, $v);
+ my $content;
+ while (($k,$v) = splice(@_, 0, 2)) {
+ if (lc($k) eq 'content') {
+ $req->add_content($v);
+ $content++;
+ }
+ else {
+ $req->push_header($k, $v);
+ }
+ }
+ if ($content && !defined($req->header("Content-Length"))) {
+ $req->header("Content-Length", length(${$req->content_ref}));
+ }
+ $req;
+}
+
+
+sub form_data # RFC1867
+{
+ my($data, $boundary, $req) = @_;
+ my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
+ my $fhparts;
+ my @parts;
+ my($k,$v);
+ while (($k,$v) = splice(@data, 0, 2)) {
+ if (!ref($v)) {
+ $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
+ push(@parts,
+ qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
+ }
+ else {
+ my($file, $usename, @headers) = @$v;
+ unless (defined $usename) {
+ $usename = $file;
+ $usename =~ s,.*/,, if defined($usename);
+ }
+ $k =~ s/([\\\"])/\\$1/g;
+ my $disp = qq(form-data; name="$k");
+ if (defined($usename) and length($usename)) {
+ $usename =~ s/([\\\"])/\\$1/g;
+ $disp .= qq(; filename="$usename");
+ }
+ my $content = "";
+ my $h = HTTP::Headers->new(@headers);
+ if ($file) {
+ open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
+ binmode($fh);
+ if ($DYNAMIC_FILE_UPLOAD) {
+ # will read file later, close it now in order to
+ # not accumulate to many open file handles
+ close($fh);
+ $content = \$file;
+ }
+ else {
+ local($/) = undef; # slurp files
+ $content = <$fh>;
+ close($fh);
+ }
+ unless ($h->header("Content-Type")) {
+ require LWP::MediaTypes;
+ LWP::MediaTypes::guess_media_type($file, $h);
+ }
+ }
+ if ($h->header("Content-Disposition")) {
+ # just to get it sorted first
+ $disp = $h->header("Content-Disposition");
+ $h->remove_header("Content-Disposition");
+ }
+ if ($h->header("Content")) {
+ $content = $h->header("Content");
+ $h->remove_header("Content");
+ }
+ my $head = join($CRLF, "Content-Disposition: $disp",
+ $h->as_string($CRLF),
+ "");
+ if (ref $content) {
+ push(@parts, [$head, $$content]);
+ $fhparts++;
+ }
+ else {
+ push(@parts, $head . $content);
+ }
+ }
+ }
+ return ("", "none") unless @parts;
+
+ my $content;
+ if ($fhparts) {
+ $boundary = boundary(10) # hopefully enough randomness
+ unless $boundary;
+
+ # add the boundaries to the @parts array
+ for (1..@parts-1) {
+ splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
+ }
+ unshift(@parts, "--$boundary$CRLF");
+ push(@parts, "$CRLF--$boundary--$CRLF");
+
+ # See if we can generate Content-Length header
+ my $length = 0;
+ for (@parts) {
+ if (ref $_) {
+ my ($head, $f) = @$_;
+ my $file_size;
+ unless ( -f $f && ($file_size = -s _) ) {
+ # The file is either a dynamic file like /dev/audio
+ # or perhaps a file in the /proc file system where
+ # stat may return a 0 size even though reading it
+ # will produce data. So we cannot make
+ # a Content-Length header.
+ undef $length;
+ last;
+ }
+ $length += $file_size + length $head;
+ }
+ else {
+ $length += length;
+ }
+ }
+ $length && $req->header('Content-Length' => $length);
+
+ # set up a closure that will return content piecemeal
+ $content = sub {
+ for (;;) {
+ unless (@parts) {
+ defined $length && $length != 0 &&
+ Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
+ return;
+ }
+ my $p = shift @parts;
+ unless (ref $p) {
+ $p .= shift @parts while @parts && !ref($parts[0]);
+ defined $length && ($length -= length $p);
+ return $p;
+ }
+ my($buf, $fh) = @$p;
+ unless (ref($fh)) {
+ my $file = $fh;
+ undef($fh);
+ open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
+ binmode($fh);
+ }
+ my $buflength = length $buf;
+ my $n = read($fh, $buf, 2048, $buflength);
+ if ($n) {
+ $buflength += $n;
+ unshift(@parts, ["", $fh]);
+ }
+ else {
+ close($fh);
+ }
+ if ($buflength) {
+ defined $length && ($length -= $buflength);
+ return $buf
+ }
+ }
+ };
+
+ }
+ else {
+ $boundary = boundary() unless $boundary;
+
+ my $bno = 0;
+ CHECK_BOUNDARY:
+ {
+ for (@parts) {
+ if (index($_, $boundary) >= 0) {
+ # must have a better boundary
+ $boundary = boundary(++$bno);
+ redo CHECK_BOUNDARY;
+ }
+ }
+ last;
+ }
+ $content = "--$boundary$CRLF" .
+ join("$CRLF--$boundary$CRLF", @parts) .
+ "$CRLF--$boundary--$CRLF";
+ }
+
+ wantarray ? ($content, $boundary) : $content;
+}
+
+
+sub boundary
+{
+ my $size = shift || return "xYzZY";
+ require MIME::Base64;
+ my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
+ $b =~ s/[\W]/X/g; # ensure alnum only
+ $b;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request::Common - Construct common HTTP::Request objects
+
+=head1 SYNOPSIS
+
+ use HTTP::Request::Common;
+ $ua = LWP::UserAgent->new;
+ $ua->request(GET 'http://www.sn.no/');
+ $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
+
+=head1 DESCRIPTION
+
+This module provide functions that return newly created C<HTTP::Request>
+objects. These functions are usually more convenient to use than the
+standard C<HTTP::Request> constructor for the most common requests. The
+following functions are provided:
+
+=over 4
+
+=item GET $url
+
+=item GET $url, Header => Value,...
+
+The GET() function returns an C<HTTP::Request> object initialized with
+the "GET" method and the specified URL. It is roughly equivalent to the
+following call
+
+ HTTP::Request->new(
+ GET => $url,
+ HTTP::Headers->new(Header => Value,...),
+ )
+
+but is less cluttered. What is different is that a header named
+C<Content> will initialize the content part of the request instead of
+setting a header field. Note that GET requests should normally not
+have a content, so this hack makes more sense for the PUT() and POST()
+functions described below.
+
+The get(...) method of C<LWP::UserAgent> exists as a shortcut for
+$ua->request(GET ...).
+
+=item HEAD $url
+
+=item HEAD $url, Header => Value,...
+
+Like GET() but the method in the request is "HEAD".
+
+The head(...) method of "LWP::UserAgent" exists as a shortcut for
+$ua->request(HEAD ...).
+
+=item PUT $url
+
+=item PUT $url, Header => Value,...
+
+=item PUT $url, Header => Value,..., Content => $content
+
+Like GET() but the method in the request is "PUT".
+
+The content of the request can be specified using the "Content"
+pseudo-header. This steals a bit of the header field namespace as
+there is no way to directly specify a header that is actually called
+"Content". If you really need this you must update the request
+returned in a separate statement.
+
+=item DELETE $url
+
+=item DELETE $url, Header => Value,...
+
+Like GET() but the method in the request is "DELETE". This function
+is not exported by default.
+
+=item POST $url
+
+=item POST $url, Header => Value,...
+
+=item POST $url, $form_ref, Header => Value,...
+
+=item POST $url, Header => Value,..., Content => $form_ref
+
+=item POST $url, Header => Value,..., Content => $content
+
+This works mostly like PUT() with "POST" as the method, but this
+function also takes a second optional array or hash reference
+parameter $form_ref. As for PUT() the content can also be specified
+directly using the "Content" pseudo-header, and you may also provide
+the $form_ref this way.
+
+The $form_ref argument can be used to pass key/value pairs for the
+form content. By default we will initialize a request using the
+C<application/x-www-form-urlencoded> content type. This means that
+you can emulate an HTML E<lt>form> POSTing like this:
+
+ POST 'http://www.perl.org/survey.cgi',
+ [ name => 'Gisle Aas',
+ email => 'gisle@aas.no',
+ gender => 'M',
+ born => '1964',
+ perc => '3%',
+ ];
+
+This will create an HTTP::Request object that looks like this:
+
+ POST http://www.perl.org/survey.cgi
+ Content-Length: 66
+ Content-Type: application/x-www-form-urlencoded
+
+ name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
+
+Multivalued form fields can be specified by either repeating the field
+name or by passing the value as an array reference.
+
+The POST method also supports the C<multipart/form-data> content used
+for I<Form-based File Upload> as specified in RFC 1867. You trigger
+this content format by specifying a content type of C<'form-data'> as
+one of the request headers. If one of the values in the $form_ref is
+an array reference, then it is treated as a file part specification
+with the following interpretation:
+
+ [ $file, $filename, Header => Value... ]
+ [ undef, $filename, Header => Value,..., Content => $content ]
+
+The first value in the array ($file) is the name of a file to open.
+This file will be read and its content placed in the request. The
+routine will croak if the file can't be opened. Use an C<undef> as
+$file value if you want to specify the content directly with a
+C<Content> header. The $filename is the filename to report in the
+request. If this value is undefined, then the basename of the $file
+will be used. You can specify an empty string as $filename if you
+want to suppress sending the filename when you provide a $file value.
+
+If a $file is provided by no C<Content-Type> header, then C<Content-Type>
+and C<Content-Encoding> will be filled in automatically with the values
+returned by LWP::MediaTypes::guess_media_type()
+
+Sending my F<~/.profile> to the survey used as example above can be
+achieved by this:
+
+ POST 'http://www.perl.org/survey.cgi',
+ Content_Type => 'form-data',
+ Content => [ name => 'Gisle Aas',
+ email => 'gisle@aas.no',
+ gender => 'M',
+ born => '1964',
+ init => ["$ENV{HOME}/.profile"],
+ ]
+
+This will create an HTTP::Request object that almost looks this (the
+boundary and the content of your F<~/.profile> is likely to be
+different):
+
+ POST http://www.perl.org/survey.cgi
+ Content-Length: 388
+ Content-Type: multipart/form-data; boundary="6G+f"
+
+ --6G+f
+ Content-Disposition: form-data; name="name"
+
+ Gisle Aas
+ --6G+f
+ Content-Disposition: form-data; name="email"
+
+ gisle@aas.no
+ --6G+f
+ Content-Disposition: form-data; name="gender"
+
+ M
+ --6G+f
+ Content-Disposition: form-data; name="born"
+
+ 1964
+ --6G+f
+ Content-Disposition: form-data; name="init"; filename=".profile"
+ Content-Type: text/plain
+
+ PATH=/local/perl/bin:$PATH
+ export PATH
+
+ --6G+f--
+
+If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
+value, then you get back a request object with a subroutine closure as
+the content attribute. This subroutine will read the content of any
+files on demand and return it in suitable chunks. This allow you to
+upload arbitrary big files without using lots of memory. You can even
+upload infinite files like F</dev/audio> if you wish; however, if
+the file is not a plain file, there will be no Content-Length header
+defined for the request. Not all servers (or server
+applications) like this. Also, if the file(s) change in size between
+the time the Content-Length is calculated and the time that the last
+chunk is delivered, the subroutine will C<Croak>.
+
+The post(...) method of "LWP::UserAgent" exists as a shortcut for
+$ua->request(POST ...).
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Request>, L<LWP::UserAgent>
+
+
+=head1 COPYRIGHT
+
+Copyright 1997-2004, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package HTTP::Response;
+
+require HTTP::Message;
+@ISA = qw(HTTP::Message);
+$VERSION = "6.03";
+
+use strict;
+use HTTP::Status ();
+
+
+
+sub new
+{
+ my($class, $rc, $msg, $header, $content) = @_;
+ my $self = $class->SUPER::new($header, $content);
+ $self->code($rc);
+ $self->message($msg);
+ $self;
+}
+
+
+sub parse
+{
+ my($class, $str) = @_;
+ my $status_line;
+ if ($str =~ s/^(.*)\n//) {
+ $status_line = $1;
+ }
+ else {
+ $status_line = $str;
+ $str = "";
+ }
+
+ my $self = $class->SUPER::parse($str);
+ my($protocol, $code, $message);
+ if ($status_line =~ /^\d{3} /) {
+ # Looks like a response created by HTTP::Response->new
+ ($code, $message) = split(' ', $status_line, 2);
+ } else {
+ ($protocol, $code, $message) = split(' ', $status_line, 3);
+ }
+ $self->protocol($protocol) if $protocol;
+ $self->code($code) if defined($code);
+ $self->message($message) if defined($message);
+ $self;
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $clone = bless $self->SUPER::clone, ref($self);
+ $clone->code($self->code);
+ $clone->message($self->message);
+ $clone->request($self->request->clone) if $self->request;
+ # we don't clone previous
+ $clone;
+}
+
+
+sub code { shift->_elem('_rc', @_); }
+sub message { shift->_elem('_msg', @_); }
+sub previous { shift->_elem('_previous',@_); }
+sub request { shift->_elem('_request', @_); }
+
+
+sub status_line
+{
+ my $self = shift;
+ my $code = $self->{'_rc'} || "000";
+ my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
+ return "$code $mess";
+}
+
+
+sub base
+{
+ my $self = shift;
+ my $base = (
+ $self->header('Content-Base'), # used to be HTTP/1.1
+ $self->header('Content-Location'), # HTTP/1.1
+ $self->header('Base'), # HTTP/1.0
+ )[0];
+ if ($base && $base =~ /^$URI::scheme_re:/o) {
+ # already absolute
+ return $HTTP::URI_CLASS->new($base);
+ }
+
+ my $req = $self->request;
+ if ($req) {
+ # if $base is undef here, the return value is effectively
+ # just a copy of $self->request->uri.
+ return $HTTP::URI_CLASS->new_abs($base, $req->uri);
+ }
+
+ # can't find an absolute base
+ return undef;
+}
+
+
+sub redirects {
+ my $self = shift;
+ my @r;
+ my $r = $self;
+ while (my $p = $r->previous) {
+ push(@r, $p);
+ $r = $p;
+ }
+ return @r unless wantarray;
+ return reverse @r;
+}
+
+
+sub filename
+{
+ my $self = shift;
+ my $file;
+
+ my $cd = $self->header('Content-Disposition');
+ if ($cd) {
+ require HTTP::Headers::Util;
+ if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
+ my ($disposition, undef, %cd_param) = @{$cd[-1]};
+ $file = $cd_param{filename};
+
+ # RFC 2047 encoded?
+ if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
+ my $charset = $1;
+ my $encoding = uc($2);
+ my $encfile = $3;
+
+ if ($encoding eq 'Q' || $encoding eq 'B') {
+ local($SIG{__DIE__});
+ eval {
+ if ($encoding eq 'Q') {
+ $encfile =~ s/_/ /g;
+ require MIME::QuotedPrint;
+ $encfile = MIME::QuotedPrint::decode($encfile);
+ }
+ else { # $encoding eq 'B'
+ require MIME::Base64;
+ $encfile = MIME::Base64::decode($encfile);
+ }
+
+ require Encode;
+ require Encode::Locale;
+ Encode::from_to($encfile, $charset, "locale_fs");
+ };
+
+ $file = $encfile unless $@;
+ }
+ }
+ }
+ }
+
+ unless (defined($file) && length($file)) {
+ my $uri;
+ if (my $cl = $self->header('Content-Location')) {
+ $uri = URI->new($cl);
+ }
+ elsif (my $request = $self->request) {
+ $uri = $request->uri;
+ }
+
+ if ($uri) {
+ $file = ($uri->path_segments)[-1];
+ }
+ }
+
+ if ($file) {
+ $file =~ s,.*[\\/],,; # basename
+ }
+
+ if ($file && !length($file)) {
+ $file = undef;
+ }
+
+ $file;
+}
+
+
+sub as_string
+{
+ require HTTP::Status;
+ my $self = shift;
+ my($eol) = @_;
+ $eol = "\n" unless defined $eol;
+
+ my $status_line = $self->status_line;
+ my $proto = $self->protocol;
+ $status_line = "$proto $status_line" if $proto;
+
+ return join($eol, $status_line, $self->SUPER::as_string(@_));
+}
+
+
+sub dump
+{
+ my $self = shift;
+
+ my $status_line = $self->status_line;
+ my $proto = $self->protocol;
+ $status_line = "$proto $status_line" if $proto;
+
+ return $self->SUPER::dump(
+ preheader => $status_line,
+ @_,
+ );
+}
+
+
+sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
+sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
+sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
+sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
+
+
+sub error_as_HTML
+{
+ my $self = shift;
+ my $title = 'An Error Occurred';
+ my $body = $self->status_line;
+ $body =~ s/&/&/g;
+ $body =~ s/</</g;
+ return <<EOM;
+<html>
+<head><title>$title</title></head>
+<body>
+<h1>$title</h1>
+<p>$body</p>
+</body>
+</html>
+EOM
+}
+
+
+sub current_age
+{
+ my $self = shift;
+ my $time = shift;
+
+ # Implementation of RFC 2616 section 13.2.3
+ # (age calculations)
+ my $response_time = $self->client_date;
+ my $date = $self->date;
+
+ my $age = 0;
+ if ($response_time && $date) {
+ $age = $response_time - $date; # apparent_age
+ $age = 0 if $age < 0;
+ }
+
+ my $age_v = $self->header('Age');
+ if ($age_v && $age_v > $age) {
+ $age = $age_v; # corrected_received_age
+ }
+
+ if ($response_time) {
+ my $request = $self->request;
+ if ($request) {
+ my $request_time = $request->date;
+ if ($request_time && $request_time < $response_time) {
+ # Add response_delay to age to get 'corrected_initial_age'
+ $age += $response_time - $request_time;
+ }
+ }
+ $age += ($time || time) - $response_time;
+ }
+ return $age;
+}
+
+
+sub freshness_lifetime
+{
+ my($self, %opt) = @_;
+
+ # First look for the Cache-Control: max-age=n header
+ for my $cc ($self->header('Cache-Control')) {
+ for my $cc_dir (split(/\s*,\s*/, $cc)) {
+ return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
+ }
+ }
+
+ # Next possibility is to look at the "Expires" header
+ my $date = $self->date || $self->client_date || $opt{time} || time;
+ if (my $expires = $self->expires) {
+ return $expires - $date;
+ }
+
+ # Must apply heuristic expiration
+ return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
+
+ # Default heuristic expiration parameters
+ $opt{h_min} ||= 60;
+ $opt{h_max} ||= 24 * 3600;
+ $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
+ $opt{h_default} ||= 3600;
+
+ # Should give a warning if more than 24 hours according to
+ # RFC 2616 section 13.2.4. Here we just make this the default
+ # maximum value.
+
+ if (my $last_modified = $self->last_modified) {
+ my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
+ return $opt{h_min} if $h_exp < $opt{h_min};
+ return $opt{h_max} if $h_exp > $opt{h_max};
+ return $h_exp;
+ }
+
+ # default when all else fails
+ return $opt{h_min} if $opt{h_min} > $opt{h_default};
+ return $opt{h_default};
+}
+
+
+sub is_fresh
+{
+ my($self, %opt) = @_;
+ $opt{time} ||= time;
+ my $f = $self->freshness_lifetime(%opt);
+ return undef unless defined($f);
+ return $f > $self->current_age($opt{time});
+}
+
+
+sub fresh_until
+{
+ my($self, %opt) = @_;
+ $opt{time} ||= time;
+ my $f = $self->freshness_lifetime(%opt);
+ return undef unless defined($f);
+ return $f - $self->current_age($opt{time}) + $opt{time};
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Response - HTTP style response message
+
+=head1 SYNOPSIS
+
+Response objects are returned by the request() method of the C<LWP::UserAgent>:
+
+ # ...
+ $response = $ua->request($request)
+ if ($response->is_success) {
+ print $response->decoded_content;
+ }
+ else {
+ print STDERR $response->status_line, "\n";
+ }
+
+=head1 DESCRIPTION
+
+The C<HTTP::Response> class encapsulates HTTP style responses. A
+response consists of a response line, some headers, and a content
+body. Note that the LWP library uses HTTP style responses even for
+non-HTTP protocol schemes. Instances of this class are usually
+created and returned by the request() method of an C<LWP::UserAgent>
+object.
+
+C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
+inherits its methods. The following additional methods are available:
+
+=over 4
+
+=item $r = HTTP::Response->new( $code )
+
+=item $r = HTTP::Response->new( $code, $msg )
+
+=item $r = HTTP::Response->new( $code, $msg, $header )
+
+=item $r = HTTP::Response->new( $code, $msg, $header, $content )
+
+Constructs a new C<HTTP::Response> object describing a response with
+response code $code and optional message $msg. The optional $header
+argument should be a reference to an C<HTTP::Headers> object or a
+plain array reference of key/value pairs. The optional $content
+argument should be a string of bytes. The meaning these arguments are
+described below.
+
+=item $r = HTTP::Response->parse( $str )
+
+This constructs a new response object by parsing the given string.
+
+=item $r->code
+
+=item $r->code( $code )
+
+This is used to get/set the code attribute. The code is a 3 digit
+number that encode the overall outcome of an HTTP response. The
+C<HTTP::Status> module provide constants that provide mnemonic names
+for the code attribute.
+
+=item $r->message
+
+=item $r->message( $message )
+
+This is used to get/set the message attribute. The message is a short
+human readable single line string that explains the response code.
+
+=item $r->header( $field )
+
+=item $r->header( $field => $value )
+
+This is used to get/set header values and it is inherited from
+C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
+details and other similar methods that can be used to access the
+headers.
+
+=item $r->content
+
+=item $r->content( $bytes )
+
+This is used to get/set the raw content and it is inherited from the
+C<HTTP::Message> base class. See L<HTTP::Message> for details and
+other methods that can be used to access the content.
+
+=item $r->decoded_content( %options )
+
+This will return the content after any C<Content-Encoding> and
+charsets have been decoded. See L<HTTP::Message> for details.
+
+=item $r->request
+
+=item $r->request( $request )
+
+This is used to get/set the request attribute. The request attribute
+is a reference to the the request that caused this response. It does
+not have to be the same request passed to the $ua->request() method,
+because there might have been redirects and authorization retries in
+between.
+
+=item $r->previous
+
+=item $r->previous( $response )
+
+This is used to get/set the previous attribute. The previous
+attribute is used to link together chains of responses. You get
+chains of responses if the first response is redirect or unauthorized.
+The value is C<undef> if this is the first response in a chain.
+
+Note that the method $r->redirects is provided as a more convenient
+way to access the response chain.
+
+=item $r->status_line
+
+Returns the string "E<lt>code> E<lt>message>". If the message attribute
+is not set then the official name of E<lt>code> (see L<HTTP::Status>)
+is substituted.
+
+=item $r->base
+
+Returns the base URI for this response. The return value will be a
+reference to a URI object.
+
+The base URI is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+Embedded in the document content, for instance <BASE HREF="...">
+in HTML documents.
+
+=item 2.
+
+A "Content-Base:" or a "Content-Location:" header in the response.
+
+For backwards compatibility with older HTTP implementations we will
+also look for the "Base:" header.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If none of these sources provide an absolute URI, undef is returned.
+
+When the LWP protocol modules produce the HTTP::Response object, then
+any base URI embedded in the document (step 1) will already have
+initialized the "Content-Base:" header. This means that this method
+only performs the last 2 steps (the content is not always available
+either).
+
+=item $r->filename
+
+Returns a filename for this response. Note that doing sanity checks
+on the returned filename (eg. removing characters that cannot be used
+on the target filesystem where the filename would be used, and
+laundering it for security purposes) are the caller's responsibility;
+the only related thing done by this method is that it makes a simple
+attempt to return a plain filename with no preceding path segments.
+
+The filename is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+A "Content-Disposition:" header in the response. Proper decoding of
+RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
+encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
+
+=item 2.
+
+A "Content-Location:" header in the response.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If a filename cannot be derived from any of these sources, undef is
+returned.
+
+=item $r->as_string
+
+=item $r->as_string( $eol )
+
+Returns a textual representation of the response.
+
+=item $r->is_info
+
+=item $r->is_success
+
+=item $r->is_redirect
+
+=item $r->is_error
+
+These methods indicate if the response was informational, successful, a
+redirection, or an error. See L<HTTP::Status> for the meaning of these.
+
+=item $r->error_as_HTML
+
+Returns a string containing a complete HTML document indicating what
+error occurred. This method should only be called when $r->is_error
+is TRUE.
+
+=item $r->redirects
+
+Returns the list of redirect responses that lead up to this response
+by following the $r->previous chain. The list order is oldest first.
+
+In scalar context return the number of redirect responses leading up
+to this one.
+
+=item $r->current_age
+
+Calculates the "current age" of the response as specified by RFC 2616
+section 13.2.3. The age of a response is the time since it was sent
+by the origin server. The returned value is a number representing the
+age in seconds.
+
+=item $r->freshness_lifetime( %opt )
+
+Calculates the "freshness lifetime" of the response as specified by
+RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
+time between the generation of a response and its expiration time.
+The returned value is the number of seconds until expiry.
+
+If the response does not contain an "Expires" or a "Cache-Control"
+header, then this function will apply some simple heuristic based on
+the "Last-Modified" header to determine a suitable lifetime. The
+following options might be passed to control the heuristics:
+
+=over
+
+=item heuristic_expiry => $bool
+
+If passed as a FALSE value, don't apply heuristics and just return
+C<undef> when "Expires" or "Cache-Control" is lacking.
+
+=item h_lastmod_fraction => $num
+
+This number represent the fraction of the difference since the
+"Last-Modified" timestamp to make the expiry time. The default is
+C<0.10>, the suggested typical setting of 10% in RFC 2616.
+
+=item h_min => $sec
+
+This is the lower limit of the heuristic expiry age to use. The
+default is C<60> (1 minute).
+
+=item h_max => $sec
+
+This is the upper limit of the heuristic expiry age to use. The
+default is C<86400> (24 hours).
+
+=item h_default => $sec
+
+This is the expiry age to use when nothing else applies. The default
+is C<3600> (1 hour) or "h_min" if greater.
+
+=back
+
+=item $r->is_fresh( %opt )
+
+Returns TRUE if the response is fresh, based on the values of
+freshness_lifetime() and current_age(). If the response is no longer
+fresh, then it has to be re-fetched or re-validated by the origin
+server.
+
+Options might be passed to control expiry heuristics, see the
+description of freshness_lifetime().
+
+=item $r->fresh_until( %opt )
+
+Returns the time (seconds since epoch) when this entity is no longer fresh.
+
+Options might be passed to control expiry heuristics, see the
+description of freshness_lifetime().
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
--- /dev/null
+package HTTP::Status;
+
+use strict;
+require 5.002; # because we use prototypes
+
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(is_info is_success is_redirect is_error status_message);
+@EXPORT_OK = qw(is_client_error is_server_error);
+$VERSION = "6.03";
+
+# Note also addition of mnemonics to @EXPORT below
+
+# Unmarked codes are from RFC 2616
+# See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+
+my %StatusCode = (
+ 100 => 'Continue',
+ 101 => 'Switching Protocols',
+ 102 => 'Processing', # RFC 2518 (WebDAV)
+ 200 => 'OK',
+ 201 => 'Created',
+ 202 => 'Accepted',
+ 203 => 'Non-Authoritative Information',
+ 204 => 'No Content',
+ 205 => 'Reset Content',
+ 206 => 'Partial Content',
+ 207 => 'Multi-Status', # RFC 2518 (WebDAV)
+ 208 => 'Already Reported', # RFC 5842
+ 300 => 'Multiple Choices',
+ 301 => 'Moved Permanently',
+ 302 => 'Found',
+ 303 => 'See Other',
+ 304 => 'Not Modified',
+ 305 => 'Use Proxy',
+ 307 => 'Temporary Redirect',
+ 400 => 'Bad Request',
+ 401 => 'Unauthorized',
+ 402 => 'Payment Required',
+ 403 => 'Forbidden',
+ 404 => 'Not Found',
+ 405 => 'Method Not Allowed',
+ 406 => 'Not Acceptable',
+ 407 => 'Proxy Authentication Required',
+ 408 => 'Request Timeout',
+ 409 => 'Conflict',
+ 410 => 'Gone',
+ 411 => 'Length Required',
+ 412 => 'Precondition Failed',
+ 413 => 'Request Entity Too Large',
+ 414 => 'Request-URI Too Large',
+ 415 => 'Unsupported Media Type',
+ 416 => 'Request Range Not Satisfiable',
+ 417 => 'Expectation Failed',
+ 418 => 'I\'m a teapot', # RFC 2324
+ 422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
+ 423 => 'Locked', # RFC 2518 (WebDAV)
+ 424 => 'Failed Dependency', # RFC 2518 (WebDAV)
+ 425 => 'No code', # WebDAV Advanced Collections
+ 426 => 'Upgrade Required', # RFC 2817
+ 428 => 'Precondition Required',
+ 429 => 'Too Many Requests',
+ 431 => 'Request Header Fields Too Large',
+ 449 => 'Retry with', # unofficial Microsoft
+ 500 => 'Internal Server Error',
+ 501 => 'Not Implemented',
+ 502 => 'Bad Gateway',
+ 503 => 'Service Unavailable',
+ 504 => 'Gateway Timeout',
+ 505 => 'HTTP Version Not Supported',
+ 506 => 'Variant Also Negotiates', # RFC 2295
+ 507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
+ 509 => 'Bandwidth Limit Exceeded', # unofficial
+ 510 => 'Not Extended', # RFC 2774
+ 511 => 'Network Authentication Required',
+);
+
+my $mnemonicCode = '';
+my ($code, $message);
+while (($code, $message) = each %StatusCode) {
+ # create mnemonic subroutines
+ $message =~ s/I'm/I am/;
+ $message =~ tr/a-z \-/A-Z__/;
+ $mnemonicCode .= "sub HTTP_$message () { $code }\n";
+ $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy
+ $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
+ $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
+}
+eval $mnemonicCode; # only one eval for speed
+die if $@;
+
+# backwards compatibility
+*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard
+push(@EXPORT, "RC_MOVED_TEMPORARILY");
+
+%EXPORT_TAGS = (
+ constants => [grep /^HTTP_/, @EXPORT_OK],
+ is => [grep /^is_/, @EXPORT, @EXPORT_OK],
+);
+
+
+sub status_message ($) { $StatusCode{$_[0]}; }
+
+sub is_info ($) { $_[0] >= 100 && $_[0] < 200; }
+sub is_success ($) { $_[0] >= 200 && $_[0] < 300; }
+sub is_redirect ($) { $_[0] >= 300 && $_[0] < 400; }
+sub is_error ($) { $_[0] >= 400 && $_[0] < 600; }
+sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; }
+sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; }
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+HTTP::Status - HTTP Status code processing
+
+=head1 SYNOPSIS
+
+ use HTTP::Status qw(:constants :is status_message);
+
+ if ($rc != HTTP_OK) {
+ print status_message($rc), "\n";
+ }
+
+ if (is_success($rc)) { ... }
+ if (is_error($rc)) { ... }
+ if (is_redirect($rc)) { ... }
+
+=head1 DESCRIPTION
+
+I<HTTP::Status> is a library of routines for defining and
+classifying HTTP status codes for libwww-perl. Status codes are
+used to encode the overall outcome of an HTTP response message. Codes
+correspond to those defined in RFC 2616 and RFC 2518.
+
+=head1 CONSTANTS
+
+The following constant functions can be used as mnemonic status code
+names. None of these are exported by default. Use the C<:constants>
+tag to import them all.
+
+ HTTP_CONTINUE (100)
+ HTTP_SWITCHING_PROTOCOLS (101)
+ HTTP_PROCESSING (102)
+
+ HTTP_OK (200)
+ HTTP_CREATED (201)
+ HTTP_ACCEPTED (202)
+ HTTP_NON_AUTHORITATIVE_INFORMATION (203)
+ HTTP_NO_CONTENT (204)
+ HTTP_RESET_CONTENT (205)
+ HTTP_PARTIAL_CONTENT (206)
+ HTTP_MULTI_STATUS (207)
+ HTTP_ALREADY_REPORTED (208)
+
+ HTTP_MULTIPLE_CHOICES (300)
+ HTTP_MOVED_PERMANENTLY (301)
+ HTTP_FOUND (302)
+ HTTP_SEE_OTHER (303)
+ HTTP_NOT_MODIFIED (304)
+ HTTP_USE_PROXY (305)
+ HTTP_TEMPORARY_REDIRECT (307)
+
+ HTTP_BAD_REQUEST (400)
+ HTTP_UNAUTHORIZED (401)
+ HTTP_PAYMENT_REQUIRED (402)
+ HTTP_FORBIDDEN (403)
+ HTTP_NOT_FOUND (404)
+ HTTP_METHOD_NOT_ALLOWED (405)
+ HTTP_NOT_ACCEPTABLE (406)
+ HTTP_PROXY_AUTHENTICATION_REQUIRED (407)
+ HTTP_REQUEST_TIMEOUT (408)
+ HTTP_CONFLICT (409)
+ HTTP_GONE (410)
+ HTTP_LENGTH_REQUIRED (411)
+ HTTP_PRECONDITION_FAILED (412)
+ HTTP_REQUEST_ENTITY_TOO_LARGE (413)
+ HTTP_REQUEST_URI_TOO_LARGE (414)
+ HTTP_UNSUPPORTED_MEDIA_TYPE (415)
+ HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416)
+ HTTP_EXPECTATION_FAILED (417)
+ HTTP_I_AM_A_TEAPOT (418)
+ HTTP_UNPROCESSABLE_ENTITY (422)
+ HTTP_LOCKED (423)
+ HTTP_FAILED_DEPENDENCY (424)
+ HTTP_NO_CODE (425)
+ HTTP_UPGRADE_REQUIRED (426)
+ HTTP_PRECONDITION_REQUIRED (428)
+ HTTP_TOO_MANY_REQUESTS (429)
+ HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431)
+ HTTP_RETRY_WITH (449)
+
+ HTTP_INTERNAL_SERVER_ERROR (500)
+ HTTP_NOT_IMPLEMENTED (501)
+ HTTP_BAD_GATEWAY (502)
+ HTTP_SERVICE_UNAVAILABLE (503)
+ HTTP_GATEWAY_TIMEOUT (504)
+ HTTP_HTTP_VERSION_NOT_SUPPORTED (505)
+ HTTP_VARIANT_ALSO_NEGOTIATES (506)
+ HTTP_INSUFFICIENT_STORAGE (507)
+ HTTP_BANDWIDTH_LIMIT_EXCEEDED (509)
+ HTTP_NOT_EXTENDED (510)
+ HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)
+
+=head1 FUNCTIONS
+
+The following additional functions are provided. Most of them are
+exported by default. The C<:is> import tag can be used to import all
+the classification functions.
+
+=over 4
+
+=item status_message( $code )
+
+The status_message() function will translate status codes to human
+readable strings. The string is the same as found in the constant
+names above. If the $code is unknown, then C<undef> is returned.
+
+=item is_info( $code )
+
+Return TRUE if C<$code> is an I<Informational> status code (1xx). This
+class of status code indicates a provisional response which can't have
+any content.
+
+=item is_success( $code )
+
+Return TRUE if C<$code> is a I<Successful> status code (2xx).
+
+=item is_redirect( $code )
+
+Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
+status code indicates that further action needs to be taken by the
+user agent in order to fulfill the request.
+
+=item is_error( $code )
+
+Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
+returns TRUE for both client and server error status codes.
+
+=item is_client_error( $code )
+
+Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
+of status code is intended for cases in which the client seems to have
+erred.
+
+This function is B<not> exported by default.
+
+=item is_server_error( $code )
+
+Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
+of status codes is intended for cases in which the server is aware
+that it has erred or is incapable of performing the request.
+
+This function is B<not> exported by default.
+
+=back
+
+=head1 BUGS
+
+For legacy reasons all the C<HTTP_> constants are exported by default
+with the prefix C<RC_>. It's recommended to use explicit imports and
+the C<:constants> tag instead of relying on this.
--- /dev/null
+package LWP::Authen::Basic;
+use strict;
+
+require MIME::Base64;
+
+sub auth_header {
+ my($class, $user, $pass) = @_;
+ return "Basic " . MIME::Base64::encode("$user:$pass", "");
+}
+
+sub authenticate
+{
+ my($class, $ua, $proxy, $auth_param, $response,
+ $request, $arg, $size) = @_;
+
+ my $realm = $auth_param->{realm} || "";
+ my $url = $proxy ? $request->{proxy} : $request->uri_canonical;
+ return $response unless $url;
+ my $host_port = $url->host_port;
+ my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
+
+ my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port);
+ push(@m, realm => $realm);
+
+ my $h = $ua->get_my_handler("request_prepare", @m, sub {
+ $_[0]{callback} = sub {
+ my($req, $ua, $h) = @_;
+ my($user, $pass) = $ua->credentials($host_port, $h->{realm});
+ if (defined $user) {
+ my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h);
+ $req->header($auth_header => $auth_value);
+ }
+ };
+ });
+ $h->{auth_param} = $auth_param;
+
+ if (!$proxy && !$request->header($auth_header) && $ua->credentials($host_port, $realm)) {
+ # we can make sure this handler applies and retry
+ add_path($h, $url->path);
+ return $ua->request($request->clone, $arg, $size, $response);
+ }
+
+ my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy);
+ unless (defined $user and defined $pass) {
+ $ua->set_my_handler("request_prepare", undef, @m); # delete handler
+ return $response;
+ }
+
+ # check that the password has changed
+ my ($olduser, $oldpass) = $ua->credentials($host_port, $realm);
+ return $response if (defined $olduser and defined $oldpass and
+ $user eq $olduser and $pass eq $oldpass);
+
+ $ua->credentials($host_port, $realm, $user, $pass);
+ add_path($h, $url->path) unless $proxy;
+ return $ua->request($request->clone, $arg, $size, $response);
+}
+
+sub add_path {
+ my($h, $path) = @_;
+ $path =~ s,[^/]+\z,,;
+ push(@{$h->{m_path_prefix}}, $path);
+}
+
+1;
--- /dev/null
+package LWP::Authen::Digest;
+
+use strict;
+use base 'LWP::Authen::Basic';
+
+require Digest::MD5;
+
+sub auth_header {
+ my($class, $user, $pass, $request, $ua, $h) = @_;
+
+ my $auth_param = $h->{auth_param};
+
+ my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}};
+ my $cnonce = sprintf "%8x", time;
+
+ my $uri = $request->uri->path_query;
+ $uri = "/" unless length $uri;
+
+ my $md5 = Digest::MD5->new;
+
+ my(@digest);
+ $md5->add(join(":", $user, $auth_param->{realm}, $pass));
+ push(@digest, $md5->hexdigest);
+ $md5->reset;
+
+ push(@digest, $auth_param->{nonce});
+
+ if ($auth_param->{qop}) {
+ push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
+ }
+
+ $md5->add(join(":", $request->method, $uri));
+ push(@digest, $md5->hexdigest);
+ $md5->reset;
+
+ $md5->add(join(":", @digest));
+ my($digest) = $md5->hexdigest;
+ $md5->reset;
+
+ my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
+ @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");
+
+ if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
+ @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
+ }
+
+ my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response);
+ if($request->method =~ /^(?:POST|PUT)$/) {
+ $md5->add($request->content);
+ my $content = $md5->hexdigest;
+ $md5->reset;
+ $md5->add(join(":", @digest[0..1], $content));
+ $md5->reset;
+ $resp{"message-digest"} = $md5->hexdigest;
+ push(@order, "message-digest");
+ }
+ push(@order, "opaque");
+ my @pairs;
+ for (@order) {
+ next unless defined $resp{$_};
+ push(@pairs, "$_=" . qq("$resp{$_}"));
+ }
+
+ my $auth_value = "Digest " . join(", ", @pairs);
+ return $auth_value;
+}
+
+1;
--- /dev/null
+package LWP::Authen::Ntlm;
+
+use strict;
+use vars qw/$VERSION/;
+
+$VERSION = "6.00";
+
+use Authen::NTLM "1.02";
+use MIME::Base64 "2.12";
+
+sub authenticate {
+ my($class, $ua, $proxy, $auth_param, $response,
+ $request, $arg, $size) = @_;
+
+ my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
+ $request->uri, $proxy);
+
+ unless(defined $user and defined $pass) {
+ return $response;
+ }
+
+ if (!$ua->conn_cache()) {
+ warn "The keep_alive option must be enabled for NTLM authentication to work. NTLM authentication aborted.\n";
+ return $response;
+ }
+
+ my($domain, $username) = split(/\\/, $user);
+
+ ntlm_domain($domain);
+ ntlm_user($username);
+ ntlm_password($pass);
+
+ my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
+
+ # my ($challenge) = $response->header('WWW-Authenticate');
+ my $challenge;
+ foreach ($response->header('WWW-Authenticate')) {
+ last if /^NTLM/ && ($challenge=$_);
+ }
+
+ if ($challenge eq 'NTLM') {
+ # First phase, send handshake
+ my $auth_value = "NTLM " . ntlm();
+ ntlm_reset();
+
+ # Need to check this isn't a repeated fail!
+ my $r = $response;
+ my $retry_count = 0;
+ while ($r) {
+ my $auth = $r->request->header($auth_header);
+ ++$retry_count if ($auth && $auth eq $auth_value);
+ if ($retry_count > 2) {
+ # here we know this failed before
+ $response->header("Client-Warning" =>
+ "Credentials for '$user' failed before");
+ return $response;
+ }
+ $r = $r->previous;
+ }
+
+ my $referral = $request->clone;
+ $referral->header($auth_header => $auth_value);
+ return $ua->request($referral, $arg, $size, $response);
+ }
+
+ else {
+ # Second phase, use the response challenge (unless non-401 code
+ # was returned, in which case, we just send back the response
+ # object, as is
+ my $auth_value;
+ if ($response->code ne '401') {
+ return $response;
+ }
+ else {
+ my $challenge;
+ foreach ($response->header('WWW-Authenticate')) {
+ last if /^NTLM/ && ($challenge=$_);
+ }
+ $challenge =~ s/^NTLM //;
+ ntlm();
+ $auth_value = "NTLM " . ntlm($challenge);
+ ntlm_reset();
+ }
+
+ my $referral = $request->clone;
+ $referral->header($auth_header => $auth_value);
+ my $response2 = $ua->request($referral, $arg, $size, $response);
+ return $response2;
+ }
+}
+
+1;
+
+
+=head1 NAME
+
+LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP
+
+=head1 SYNOPSIS
+
+ use LWP::UserAgent;
+ use HTTP::Request::Common;
+ my $url = 'http://www.company.com/protected_page.html';
+
+ # Set up the ntlm client and then the base64 encoded ntlm handshake message
+ my $ua = LWP::UserAgent->new(keep_alive=>1);
+ $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
+
+ $request = GET $url;
+ print "--Performing request now...-----------\n";
+ $response = $ua->request($request);
+ print "--Done with request-------------------\n";
+
+ if ($response->is_success) {print "It worked!->" . $response->code . "\n"}
+ else {print "It didn't work!->" . $response->code . "\n"}
+
+=head1 DESCRIPTION
+
+C<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the
+NTLM authentication scheme popularized by Microsoft. This type of authentication is
+common on intranets of Microsoft-centric organizations.
+
+The module takes advantage of the Authen::NTLM module by Mark Bush. Since there
+is also another Authen::NTLM module available from CPAN by Yee Man Chan with an
+entirely different interface, it is necessary to ensure that you have the correct
+NTLM module.
+
+In addition, there have been problems with incompatibilities between different
+versions of Mime::Base64, which Bush's Authen::NTLM makes use of. Therefore, it is
+necessary to ensure that your Mime::Base64 module supports exporting of the
+encode_base64 and decode_base64 functions.
+
+=head1 USAGE
+
+The module is used indirectly through LWP, rather than including it directly in your
+code. The LWP system will invoke the NTLM authentication when it encounters the
+authentication scheme while attempting to retrieve a URL from a server. In order
+for the NTLM authentication to work, you must have a few things set up in your
+code prior to attempting to retrieve the URL:
+
+=over 4
+
+=item *
+
+Enable persistent HTTP connections
+
+To do this, pass the "keep_alive=>1" option to the LWP::UserAgent when creating it, like this:
+
+ my $ua = LWP::UserAgent->new(keep_alive=>1);
+
+=item *
+
+Set the credentials on the UserAgent object
+
+The credentials must be set like this:
+
+ $ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
+
+Note that you cannot use the HTTP::Request object's authorization_basic() method to set
+the credentials. Note, too, that the 'www.company.com:80' portion only sets credentials
+on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and
+has nothing to do with LWP::Authen::Ntlm)
+
+=back
+
+=head1 AVAILABILITY
+
+General queries regarding LWP should be made to the LWP Mailing List.
+
+Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002 James Tillman. All rights reserved. This
+program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<LWP>, L<LWP::UserAgent>, L<lwpcook>.
--- /dev/null
+package LWP::ConnCache;
+
+use strict;
+use vars qw($VERSION $DEBUG);
+
+$VERSION = "6.02";
+
+
+sub new {
+ my($class, %cnf) = @_;
+
+ my $total_capacity = 1;
+ if (exists $cnf{total_capacity}) {
+ $total_capacity = delete $cnf{total_capacity};
+ }
+ if (%cnf && $^W) {
+ require Carp;
+ Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
+ }
+ my $self = bless { cc_conns => [] }, $class;
+ $self->total_capacity($total_capacity);
+ $self;
+}
+
+
+sub deposit {
+ my($self, $type, $key, $conn) = @_;
+ push(@{$self->{cc_conns}}, [$conn, $type, $key, time]);
+ $self->enforce_limits($type);
+ return;
+}
+
+
+sub withdraw {
+ my($self, $type, $key) = @_;
+ my $conns = $self->{cc_conns};
+ for my $i (0 .. @$conns - 1) {
+ my $c = $conns->[$i];
+ next unless $c->[1] eq $type && $c->[2] eq $key;
+ splice(@$conns, $i, 1); # remove it
+ return $c->[0];
+ }
+ return undef;
+}
+
+
+sub total_capacity {
+ my $self = shift;
+ my $old = $self->{cc_limit_total};
+ if (@_) {
+ $self->{cc_limit_total} = shift;
+ $self->enforce_limits;
+ }
+ $old;
+}
+
+
+sub capacity {
+ my $self = shift;
+ my $type = shift;
+ my $old = $self->{cc_limit}{$type};
+ if (@_) {
+ $self->{cc_limit}{$type} = shift;
+ $self->enforce_limits($type);
+ }
+ $old;
+}
+
+
+sub enforce_limits {
+ my($self, $type) = @_;
+ my $conns = $self->{cc_conns};
+
+ my @types = $type ? ($type) : ($self->get_types);
+ for $type (@types) {
+ next unless $self->{cc_limit};
+ my $limit = $self->{cc_limit}{$type};
+ next unless defined $limit;
+ for my $i (reverse 0 .. @$conns - 1) {
+ next unless $conns->[$i][1] eq $type;
+ if (--$limit < 0) {
+ $self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded");
+ }
+ }
+ }
+
+ if (defined(my $total = $self->{cc_limit_total})) {
+ while (@$conns > $total) {
+ $self->dropping(shift(@$conns), "Total capacity exceeded");
+ }
+ }
+}
+
+
+sub dropping {
+ my($self, $c, $reason) = @_;
+ print "DROPPING @$c [$reason]\n" if $DEBUG;
+}
+
+
+sub drop {
+ my($self, $checker, $reason) = @_;
+ if (ref($checker) ne "CODE") {
+ # make it so
+ if (!defined $checker) {
+ $checker = sub { 1 }; # drop all of them
+ }
+ elsif (_looks_like_number($checker)) {
+ my $age_limit = $checker;
+ my $time_limit = time - $age_limit;
+ $reason ||= "older than $age_limit";
+ $checker = sub { $_[3] < $time_limit };
+ }
+ else {
+ my $type = $checker;
+ $reason ||= "drop $type";
+ $checker = sub { $_[1] eq $type }; # match on type
+ }
+ }
+ $reason ||= "drop";
+
+ local $SIG{__DIE__}; # don't interfere with eval below
+ local $@;
+ my @c;
+ for (@{$self->{cc_conns}}) {
+ my $drop;
+ eval {
+ if (&$checker(@$_)) {
+ $self->dropping($_, $reason);
+ $drop++;
+ }
+ };
+ push(@c, $_) unless $drop;
+ }
+ @{$self->{cc_conns}} = @c;
+}
+
+
+sub prune {
+ my $self = shift;
+ $self->drop(sub { !shift->ping }, "ping");
+}
+
+
+sub get_types {
+ my $self = shift;
+ my %t;
+ $t{$_->[1]}++ for @{$self->{cc_conns}};
+ return keys %t;
+}
+
+
+sub get_connections {
+ my($self, $type) = @_;
+ my @c;
+ for (@{$self->{cc_conns}}) {
+ push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]);
+ }
+ @c;
+}
+
+
+sub _looks_like_number {
+ $_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+LWP::ConnCache - Connection cache manager
+
+=head1 NOTE
+
+This module is experimental. Details of its interface is likely to
+change in the future.
+
+=head1 SYNOPSIS
+
+ use LWP::ConnCache;
+ my $cache = LWP::ConnCache->new;
+ $cache->deposit($type, $key, $sock);
+ $sock = $cache->withdraw($type, $key);
+
+=head1 DESCRIPTION
+
+The C<LWP::ConnCache> class is the standard connection cache manager
+for LWP::UserAgent.
+
+The following basic methods are provided:
+
+=over
+
+=item $cache = LWP::ConnCache->new( %options )
+
+This method constructs a new C<LWP::ConnCache> object. The only
+option currently accepted is 'total_capacity'. If specified it
+initialize the total_capacity option. It defaults to the value 1.
+
+=item $cache->total_capacity( [$num_connections] )
+
+Get/sets the number of connection that will be cached. Connections
+will start to be dropped when this limit is reached. If set to C<0>,
+then all connections are immediately dropped. If set to C<undef>,
+then there is no limit.
+
+=item $cache->capacity($type, [$num_connections] )
+
+Get/set a limit for the number of connections of the specified type
+that can be cached. The $type will typically be a short string like
+"http" or "ftp".
+
+=item $cache->drop( [$checker, [$reason]] )
+
+Drop connections by some criteria. The $checker argument is a
+subroutine that is called for each connection. If the routine returns
+a TRUE value then the connection is dropped. The routine is called
+with ($conn, $type, $key, $deposit_time) as arguments.
+
+Shortcuts: If the $checker argument is absent (or C<undef>) all cached
+connections are dropped. If the $checker is a number then all
+connections untouched that the given number of seconds or more are
+dropped. If $checker is a string then all connections of the given
+type are dropped.
+
+The $reason argument is passed on to the dropped() method.
+
+=item $cache->prune
+
+Calling this method will drop all connections that are dead. This is
+tested by calling the ping() method on the connections. If the ping()
+method exists and returns a FALSE value, then the connection is
+dropped.
+
+=item $cache->get_types
+
+This returns all the 'type' fields used for the currently cached
+connections.
+
+=item $cache->get_connections( [$type] )
+
+This returns all connection objects of the specified type. If no type
+is specified then all connections are returned. In scalar context the
+number of cached connections of the specified type is returned.
+
+=back
+
+
+The following methods are called by low-level protocol modules to
+try to save away connections and to get them back.
+
+=over
+
+=item $cache->deposit($type, $key, $conn)
+
+This method adds a new connection to the cache. As a result other
+already cached connections might be dropped. Multiple connections with
+the same $type/$key might added.
+
+=item $conn = $cache->withdraw($type, $key)
+
+This method tries to fetch back a connection that was previously
+deposited. If no cached connection with the specified $type/$key is
+found, then C<undef> is returned. There is not guarantee that a
+deposited connection can be withdrawn, as the cache manger is free to
+drop connections at any time.
+
+=back
+
+The following methods are called internally. Subclasses might want to
+override them.
+
+=over
+
+=item $conn->enforce_limits([$type])
+
+This method is called with after a new connection is added (deposited)
+in the cache or capacity limits are adjusted. The default
+implementation drops connections until the specified capacity limits
+are not exceeded.
+
+=item $conn->dropping($conn_record, $reason)
+
+This method is called when a connection is dropped. The record
+belonging to the dropped connection is passed as the first argument
+and a string describing the reason for the drop is passed as the
+second argument. The default implementation makes some noise if the
+$LWP::ConnCache::DEBUG variable is set and nothing more.
+
+=back
+
+=head1 SUBCLASSING
+
+For specialized cache policy it makes sense to subclass
+C<LWP::ConnCache> and perhaps override the deposit(), enforce_limits()
+and dropping() methods.
+
+The object itself is a hash. Keys prefixed with C<cc_> are reserved
+for the base class.
+
+=head1 SEE ALSO
+
+L<LWP::UserAgent>
+
+=head1 COPYRIGHT
+
+Copyright 2001 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
--- /dev/null
+package LWP::Debug; # legacy
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(level trace debug conns);
+
+use Carp ();
+
+my @levels = qw(trace debug conns);
+%current_level = ();
+
+
+sub import
+{
+ my $pack = shift;
+ my $callpkg = caller(0);
+ my @symbols = ();
+ my @levels = ();
+ for (@_) {
+ if (/^[-+]/) {
+ push(@levels, $_);
+ }
+ else {
+ push(@symbols, $_);
+ }
+ }
+ Exporter::export($pack, $callpkg, @symbols);
+ level(@levels);
+}
+
+
+sub level
+{
+ for (@_) {
+ if ($_ eq '+') { # all on
+ # switch on all levels
+ %current_level = map { $_ => 1 } @levels;
+ }
+ elsif ($_ eq '-') { # all off
+ %current_level = ();
+ }
+ elsif (/^([-+])(\w+)$/) {
+ $current_level{$2} = $1 eq '+';
+ }
+ else {
+ Carp::croak("Illegal level format $_");
+ }
+ }
+}
+
+
+sub trace { _log(@_) if $current_level{'trace'}; }
+sub debug { _log(@_) if $current_level{'debug'}; }
+sub conns { _log(@_) if $current_level{'conns'}; }
+
+
+sub _log
+{
+ my $msg = shift;
+ $msg .= "\n" unless $msg =~ /\n$/; # ensure trailing "\n"
+
+ my($package,$filename,$line,$sub) = caller(2);
+ print STDERR "$sub: $msg";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::Debug - deprecated
+
+=head1 DESCRIPTION
+
+LWP::Debug used to provide tracing facilities, but these are not used
+by LWP any more. The code in this module is kept around
+(undocumented) so that 3rd party code that happen to use the old
+interfaces continue to run.
+
+One useful feature that LWP::Debug provided (in an imprecise and
+troublesome way) was network traffic monitoring. The following
+section provide some hints about recommened replacements.
+
+=head2 Network traffic monitoring
+
+The best way to monitor the network traffic that LWP generates is to
+use an external TCP monitoring program. The Wireshark program
+(L<http://www.wireshark.org/>) is higly recommended for this.
+
+Another approach it to use a debugging HTTP proxy server and make
+LWP direct all its traffic via this one. Call C<< $ua->proxy >> to
+set it up and then just use LWP as before.
+
+For less precise monitoring needs just setting up a few simple
+handlers might do. The following example sets up handlers to dump the
+request and response objects that pass through LWP:
+
+ use LWP::UserAgent;
+ $ua = LWP::UserAgent->new;
+ $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
+
+ $ua->add_handler("request_send", sub { shift->dump; return });
+ $ua->add_handler("response_done", sub { shift->dump; return });
+
+ $ua->get("http://www.example.com");
+
+=head1 SEE ALSO
+
+L<LWP::UserAgent>
--- /dev/null
+package LWP::DebugFile;
+
+# legacy stub
+
+1;
--- /dev/null
+package LWP::MemberMixin;
+
+sub _elem
+{
+ my $self = shift;
+ my $elem = shift;
+ my $old = $self->{$elem};
+ $self->{$elem} = shift if @_;
+ return $old;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::MemberMixin - Member access mixin class
+
+=head1 SYNOPSIS
+
+ package Foo;
+ require LWP::MemberMixin;
+ @ISA=qw(LWP::MemberMixin);
+
+=head1 DESCRIPTION
+
+A mixin class to get methods that provide easy access to member
+variables in the %$self.
+Ideally there should be better Perl language support for this.
+
+There is only one method provided:
+
+=over 4
+
+=item _elem($elem [, $val])
+
+Internal method to get/set the value of member variable
+C<$elem>. If C<$val> is present it is used as the new value
+for the member variable. If it is not present the current
+value is not touched. In both cases the previous value of
+the member variable is returned.
+
+=back
--- /dev/null
+package LWP::Protocol;
+
+require LWP::MemberMixin;
+@ISA = qw(LWP::MemberMixin);
+$VERSION = "6.00";
+
+use strict;
+use Carp ();
+use HTTP::Status ();
+use HTTP::Response;
+
+my %ImplementedBy = (); # scheme => classname
+
+
+
+sub new
+{
+ my($class, $scheme, $ua) = @_;
+
+ my $self = bless {
+ scheme => $scheme,
+ ua => $ua,
+
+ # historical/redundant
+ max_size => $ua->{max_size},
+ }, $class;
+
+ $self;
+}
+
+
+sub create
+{
+ my($scheme, $ua) = @_;
+ my $impclass = LWP::Protocol::implementor($scheme) or
+ Carp::croak("Protocol scheme '$scheme' is not supported");
+
+ # hand-off to scheme specific implementation sub-class
+ my $protocol = $impclass->new($scheme, $ua);
+
+ return $protocol;
+}
+
+
+sub implementor
+{
+ my($scheme, $impclass) = @_;
+
+ if ($impclass) {
+ $ImplementedBy{$scheme} = $impclass;
+ }
+ my $ic = $ImplementedBy{$scheme};
+ return $ic if $ic;
+
+ return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes
+ $scheme = $1; # untaint
+ $scheme =~ s/[.+\-]/_/g; # make it a legal module name
+
+ # scheme not yet known, look for a 'use'd implementation
+ $ic = "LWP::Protocol::$scheme"; # default location
+ $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
+ no strict 'refs';
+ # check we actually have one for the scheme:
+ unless (@{"${ic}::ISA"}) {
+ # try to autoload it
+ eval "require $ic";
+ if ($@) {
+ if ($@ =~ /Can't locate/) { #' #emacs get confused by '
+ $ic = '';
+ }
+ else {
+ die "$@\n";
+ }
+ }
+ }
+ $ImplementedBy{$scheme} = $ic if $ic;
+ $ic;
+}
+
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+ Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
+}
+
+
+# legacy
+sub timeout { shift->_elem('timeout', @_); }
+sub max_size { shift->_elem('max_size', @_); }
+
+
+sub collect
+{
+ my ($self, $arg, $response, $collector) = @_;
+ my $content;
+ my($ua, $max_size) = @{$self}{qw(ua max_size)};
+
+ eval {
+ local $\; # protect the print below from surprises
+ if (!defined($arg) || !$response->is_success) {
+ $response->{default_add_content} = 1;
+ }
+ elsif (!ref($arg) && length($arg)) {
+ open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
+ binmode($fh);
+ push(@{$response->{handlers}{response_data}}, {
+ callback => sub {
+ print $fh $_[3] or die "Can't write to '$arg': $!";
+ 1;
+ },
+ });
+ push(@{$response->{handlers}{response_done}}, {
+ callback => sub {
+ close($fh) or die "Can't write to '$arg': $!";
+ undef($fh);
+ },
+ });
+ }
+ elsif (ref($arg) eq 'CODE') {
+ push(@{$response->{handlers}{response_data}}, {
+ callback => sub {
+ &$arg($_[3], $_[0], $self);
+ 1;
+ },
+ });
+ }
+ else {
+ die "Unexpected collect argument '$arg'";
+ }
+
+ $ua->run_handlers("response_header", $response);
+
+ if (delete $response->{default_add_content}) {
+ push(@{$response->{handlers}{response_data}}, {
+ callback => sub {
+ $_[0]->add_content($_[3]);
+ 1;
+ },
+ });
+ }
+
+
+ my $content_size = 0;
+ my $length = $response->content_length;
+ my %skip_h;
+
+ while ($content = &$collector, length $$content) {
+ for my $h ($ua->handlers("response_data", $response)) {
+ next if $skip_h{$h};
+ unless ($h->{callback}->($response, $ua, $h, $$content)) {
+ # XXX remove from $response->{handlers}{response_data} if present
+ $skip_h{$h}++;
+ }
+ }
+ $content_size += length($$content);
+ $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
+ if (defined($max_size) && $content_size > $max_size) {
+ $response->push_header("Client-Aborted", "max_size");
+ last;
+ }
+ }
+ };
+ my $err = $@;
+ delete $response->{handlers}{response_data};
+ delete $response->{handlers} unless %{$response->{handlers}};
+ if ($err) {
+ chomp($err);
+ $response->push_header('X-Died' => $err);
+ $response->push_header("Client-Aborted", "die");
+ return $response;
+ }
+
+ return $response;
+}
+
+
+sub collect_once
+{
+ my($self, $arg, $response) = @_;
+ my $content = \ $_[3];
+ my $first = 1;
+ $self->collect($arg, $response, sub {
+ return $content if $first--;
+ return \ "";
+ });
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+LWP::Protocol - Base class for LWP protocols
+
+=head1 SYNOPSIS
+
+ package LWP::Protocol::foo;
+ require LWP::Protocol;
+ @ISA=qw(LWP::Protocol);
+
+=head1 DESCRIPTION
+
+This class is used a the base class for all protocol implementations
+supported by the LWP library.
+
+When creating an instance of this class using
+C<LWP::Protocol::create($url)>, and you get an initialised subclass
+appropriate for that access method. In other words, the
+LWP::Protocol::create() function calls the constructor for one of its
+subclasses.
+
+All derived LWP::Protocol classes need to override the request()
+method which is used to service a request. The overridden method can
+make use of the collect() function to collect together chunks of data
+as it is received.
+
+The following methods and functions are provided:
+
+=over 4
+
+=item $prot = LWP::Protocol->new()
+
+The LWP::Protocol constructor is inherited by subclasses. As this is a
+virtual base class this method should B<not> be called directly.
+
+=item $prot = LWP::Protocol::create($scheme)
+
+Create an object of the class implementing the protocol to handle the
+given scheme. This is a function, not a method. It is more an object
+factory than a constructor. This is the function user agents should
+use to access protocols.
+
+=item $class = LWP::Protocol::implementor($scheme, [$class])
+
+Get and/or set implementor class for a scheme. Returns '' if the
+specified scheme is not supported.
+
+=item $prot->request(...)
+
+ $response = $protocol->request($request, $proxy, undef);
+ $response = $protocol->request($request, $proxy, '/tmp/sss');
+ $response = $protocol->request($request, $proxy, \&callback, 1024);
+
+Dispatches a request over the protocol, and returns a response
+object. This method needs to be overridden in subclasses. Refer to
+L<LWP::UserAgent> for description of the arguments.
+
+=item $prot->collect($arg, $response, $collector)
+
+Called to collect the content of a request, and process it
+appropriately into a scalar, file, or by calling a callback. If $arg
+is undefined, then the content is stored within the $response. If
+$arg is a simple scalar, then $arg is interpreted as a file name and
+the content is written to this file. If $arg is a reference to a
+routine, then content is passed to this routine.
+
+The $collector is a routine that will be called and which is
+responsible for returning pieces (as ref to scalar) of the content to
+process. The $collector signals EOF by returning a reference to an
+empty sting.
+
+The return value from collect() is the $response object reference.
+
+B<Note:> We will only use the callback or file argument if
+$response->is_success(). This avoids sending content data for
+redirects and authentication responses to the callback which would be
+confusing.
+
+=item $prot->collect_once($arg, $response, $content)
+
+Can be called when the whole response content is available as
+$content. This will invoke collect() with a collector callback that
+returns a reference to $content the first time and an empty string the
+next.
+
+=back
+
+=head1 SEE ALSO
+
+Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
+for examples of usage.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2001 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
--- /dev/null
+package LWP::Protocol::GHTTP;
+
+# You can tell LWP to use this module for 'http' requests by running
+# code like this before you make requests:
+#
+# require LWP::Protocol::GHTTP;
+# LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP');
+#
+
+use strict;
+use vars qw(@ISA);
+
+require LWP::Protocol;
+@ISA=qw(LWP::Protocol);
+
+require HTTP::Response;
+require HTTP::Status;
+
+use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST);
+
+my %METHOD =
+(
+ GET => METHOD_GET,
+ HEAD => METHOD_HEAD,
+ POST => METHOD_POST,
+);
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+ my $method = $request->method;
+ unless (exists $METHOD{$method}) {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ "Bad method '$method'");
+ }
+
+ my $r = HTTP::GHTTP->new($request->uri);
+
+ # XXX what headers for repeated headers here?
+ $request->headers->scan(sub { $r->set_header(@_)});
+
+ $r->set_type($METHOD{$method});
+
+ # XXX should also deal with subroutine content.
+ my $cref = $request->content_ref;
+ $r->set_body($$cref) if length($$cref);
+
+ # XXX is this right
+ $r->set_proxy($proxy->as_string) if $proxy;
+
+ $r->process_request;
+
+ my $response = HTTP::Response->new($r->get_status);
+
+ # XXX How can get the headers out of $r?? This way is too stupid.
+ my @headers;
+ eval {
+ # Wrapped in eval because this method is not always available
+ @headers = $r->get_headers;
+ };
+ @headers = qw(Date Connection Server Content-type
+ Accept-Ranges Server
+ Content-Length Last-Modified ETag) if $@;
+ for (@headers) {
+ my $v = $r->get_header($_);
+ $response->header($_ => $v) if defined $v;
+ }
+
+ return $self->collect_once($arg, $response, $r->get_body);
+}
+
+1;
--- /dev/null
+package LWP::Protocol::cpan;
+
+use strict;
+use vars qw(@ISA);
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require URI;
+require HTTP::Status;
+require HTTP::Response;
+
+our $CPAN;
+
+unless ($CPAN) {
+ # Try to find local CPAN mirror via $CPAN::Config
+ eval {
+ require CPAN::Config;
+ if($CPAN::Config) {
+ my $urls = $CPAN::Config->{urllist};
+ if (ref($urls) eq "ARRAY") {
+ my $file;
+ for (@$urls) {
+ if (/^file:/) {
+ $file = $_;
+ last;
+ }
+ }
+
+ if ($file) {
+ $CPAN = $file;
+ }
+ else {
+ $CPAN = $urls->[0];
+ }
+ }
+ }
+ };
+
+ $CPAN ||= "http://cpan.org/"; # last resort
+}
+
+# ensure that we don't chop of last part
+$CPAN .= "/" unless $CPAN =~ m,/$,;
+
+
+sub request {
+ my($self, $request, $proxy, $arg, $size) = @_;
+ # check proxy
+ if (defined $proxy)
+ {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy with cpan');
+ }
+
+ # check method
+ my $method = $request->method;
+ unless ($method eq 'GET' || $method eq 'HEAD') {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'cpan:' URLs");
+ }
+
+ my $path = $request->uri->path;
+ $path =~ s,^/,,;
+
+ my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND);
+ $response->header("Location" => URI->new_abs($path, $CPAN));
+ $response;
+}
+
+1;
--- /dev/null
+package LWP::Protocol::data;
+
+# Implements access to data:-URLs as specified in RFC 2397
+
+use strict;
+use vars qw(@ISA);
+
+require HTTP::Response;
+require HTTP::Status;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+use HTTP::Date qw(time2str);
+require LWP; # needs version number
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size) = @_;
+
+ # check proxy
+ if (defined $proxy)
+ {
+ return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy with data');
+ }
+
+ # check method
+ my $method = $request->method;
+ unless ($method eq 'GET' || $method eq 'HEAD') {
+ return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'data:' URLs");
+ }
+
+ my $url = $request->uri;
+ my $response = HTTP::Response->new( &HTTP::Status::RC_OK, "Document follows");
+
+ my $media_type = $url->media_type;
+
+ my $data = $url->data;
+ $response->header('Content-Type' => $media_type,
+ 'Content-Length' => length($data),
+ 'Date' => time2str(time),
+ 'Server' => "libwww-perl-internal/$LWP::VERSION"
+ );
+
+ $data = "" if $method eq "HEAD";
+ return $self->collect_once($arg, $response, $data);
+}
+
+1;
--- /dev/null
+package LWP::Protocol::file;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+use strict;
+
+require LWP::MediaTypes;
+require HTTP::Request;
+require HTTP::Response;
+require HTTP::Status;
+require HTTP::Date;
+
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size) = @_;
+
+ $size = 4096 unless defined $size and $size > 0;
+
+ # check proxy
+ if (defined $proxy)
+ {
+ return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy through the filesystem');
+ }
+
+ # check method
+ my $method = $request->method;
+ unless ($method eq 'GET' || $method eq 'HEAD') {
+ return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'file:' URLs");
+ }
+
+ # check url
+ my $url = $request->uri;
+
+ my $scheme = $url->scheme;
+ if ($scheme ne 'file') {
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "LWP::Protocol::file::request called for '$scheme'");
+ }
+
+ # URL OK, look at file
+ my $path = $url->file;
+
+ # test file exists and is readable
+ unless (-e $path) {
+ return HTTP::Response->new( &HTTP::Status::RC_NOT_FOUND,
+ "File `$path' does not exist");
+ }
+ unless (-r _) {
+ return HTTP::Response->new( &HTTP::Status::RC_FORBIDDEN,
+ 'User does not have read permission');
+ }
+
+ # looks like file exists
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat(_);
+
+ # XXX should check Accept headers?
+
+ # check if-modified-since
+ my $ims = $request->header('If-Modified-Since');
+ if (defined $ims) {
+ my $time = HTTP::Date::str2time($ims);
+ if (defined $time and $time >= $mtime) {
+ return HTTP::Response->new( &HTTP::Status::RC_NOT_MODIFIED,
+ "$method $path");
+ }
+ }
+
+ # Ok, should be an OK response by now...
+ my $response = HTTP::Response->new( &HTTP::Status::RC_OK );
+
+ # fill in response headers
+ $response->header('Last-Modified', HTTP::Date::time2str($mtime));
+
+ if (-d _) { # If the path is a directory, process it
+ # generate the HTML for directory
+ opendir(D, $path) or
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "Cannot read directory '$path': $!");
+ my(@files) = sort readdir(D);
+ closedir(D);
+
+ # Make directory listing
+ require URI::Escape;
+ require HTML::Entities;
+ my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
+ for (@files) {
+ my $furl = URI::Escape::uri_escape($_);
+ if ( -d "$pathe$_" ) {
+ $furl .= '/';
+ $_ .= '/';
+ }
+ my $desc = HTML::Entities::encode($_);
+ $_ = qq{<LI><A HREF="$furl">$desc</A>};
+ }
+ # Ensure that the base URL is "/" terminated
+ my $base = $url->clone;
+ unless ($base->path =~ m|/$|) {
+ $base->path($base->path . "/");
+ }
+ my $html = join("\n",
+ "<HTML>\n<HEAD>",
+ "<TITLE>Directory $path</TITLE>",
+ "<BASE HREF=\"$base\">",
+ "</HEAD>\n<BODY>",
+ "<H1>Directory listing of $path</H1>",
+ "<UL>", @files, "</UL>",
+ "</BODY>\n</HTML>\n");
+
+ $response->header('Content-Type', 'text/html');
+ $response->header('Content-Length', length $html);
+ $html = "" if $method eq "HEAD";
+
+ return $self->collect_once($arg, $response, $html);
+
+ }
+
+ # path is a regular file
+ $response->header('Content-Length', $filesize);
+ LWP::MediaTypes::guess_media_type($path, $response);
+
+ # read the file
+ if ($method ne "HEAD") {
+ open(F, $path) or return new
+ HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "Cannot read file '$path': $!");
+ binmode(F);
+ $response = $self->collect($arg, $response, sub {
+ my $content = "";
+ my $bytes = sysread(F, $content, $size);
+ return \$content if $bytes > 0;
+ return \ "";
+ });
+ close(F);
+ }
+
+ $response;
+}
+
+1;
--- /dev/null
+package LWP::Protocol::ftp;
+
+# Implementation of the ftp protocol (RFC 959). We let the Net::FTP
+# package do all the dirty work.
+
+use Carp ();
+
+use HTTP::Status ();
+use HTTP::Negotiate ();
+use HTTP::Response ();
+use LWP::MediaTypes ();
+use File::Listing ();
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+use strict;
+eval {
+ package LWP::Protocol::MyFTP;
+
+ require Net::FTP;
+ Net::FTP->require_version(2.00);
+
+ use vars qw(@ISA);
+ @ISA=qw(Net::FTP);
+
+ sub new {
+ my $class = shift;
+
+ my $self = $class->SUPER::new(@_) || return undef;
+
+ my $mess = $self->message; # welcome message
+ $mess =~ s|\n.*||s; # only first line left
+ $mess =~ s|\s*ready\.?$||;
+ # Make the version number more HTTP like
+ $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
+ ${*$self}{myftp_server} = $mess;
+ #$response->header("Server", $mess);
+
+ $self;
+ }
+
+ sub http_server {
+ my $self = shift;
+ ${*$self}{myftp_server};
+ }
+
+ sub home {
+ my $self = shift;
+ my $old = ${*$self}{myftp_home};
+ if (@_) {
+ ${*$self}{myftp_home} = shift;
+ }
+ $old;
+ }
+
+ sub go_home {
+ my $self = shift;
+ $self->cwd(${*$self}{myftp_home});
+ }
+
+ sub request_count {
+ my $self = shift;
+ ++${*$self}{myftp_reqcount};
+ }
+
+ sub ping {
+ my $self = shift;
+ return $self->go_home;
+ }
+
+};
+my $init_failed = $@;
+
+
+sub _connect {
+ my($self, $host, $port, $user, $account, $password, $timeout) = @_;
+
+ my $key;
+ my $conn_cache = $self->{ua}{conn_cache};
+ if ($conn_cache) {
+ $key = "$host:$port:$user";
+ $key .= ":$account" if defined($account);
+ if (my $ftp = $conn_cache->withdraw("ftp", $key)) {
+ if ($ftp->ping) {
+ # save it again
+ $conn_cache->deposit("ftp", $key, $ftp);
+ return $ftp;
+ }
+ }
+ }
+
+ # try to make a connection
+ my $ftp = LWP::Protocol::MyFTP->new($host,
+ Port => $port,
+ Timeout => $timeout,
+ LocalAddr => $self->{ua}{local_address},
+ );
+ # XXX Should be some what to pass on 'Passive' (header??)
+ unless ($ftp) {
+ $@ =~ s/^Net::FTP: //;
+ return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
+ }
+
+ unless ($ftp->login($user, $password, $account)) {
+ # Unauthorized. Let's fake a RC_UNAUTHORIZED response
+ my $mess = scalar($ftp->message);
+ $mess =~ s/\n$//;
+ my $res = HTTP::Response->new(&HTTP::Status::RC_UNAUTHORIZED, $mess);
+ $res->header("Server", $ftp->http_server);
+ $res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
+ return $res;
+ }
+
+ my $home = $ftp->pwd;
+ $ftp->home($home);
+
+ $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache;
+
+ return $ftp;
+}
+
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+ $size = 4096 unless $size;
+
+ # check proxy
+ if (defined $proxy)
+ {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy through the ftp');
+ }
+
+ my $url = $request->uri;
+ if ($url->scheme ne 'ftp') {
+ my $scheme = $url->scheme;
+ return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "LWP::Protocol::ftp::request called for '$scheme'");
+ }
+
+ # check method
+ my $method = $request->method;
+
+ unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'ftp:' URLs");
+ }
+
+ if ($init_failed) {
+ return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ $init_failed);
+ }
+
+ my $host = $url->host;
+ my $port = $url->port;
+ my $user = $url->user;
+ my $password = $url->password;
+
+ # If a basic autorization header is present than we prefer these over
+ # the username/password specified in the URL.
+ {
+ my($u,$p) = $request->authorization_basic;
+ if (defined $u) {
+ $user = $u;
+ $password = $p;
+ }
+ }
+
+ # We allow the account to be specified in the "Account" header
+ my $account = $request->header('Account');
+
+ my $ftp = $self->_connect($host, $port, $user, $account, $password, $timeout);
+ return $ftp if ref($ftp) eq "HTTP::Response"; # ugh!
+
+ # Create an initial response object
+ my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+ $response->header(Server => $ftp->http_server);
+ $response->header('Client-Request-Num' => $ftp->request_count);
+ $response->request($request);
+
+ # Get & fix the path
+ my @path = grep { length } $url->path_segments;
+ my $remote_file = pop(@path);
+ $remote_file = '' unless defined $remote_file;
+
+ my $type;
+ if (ref $remote_file) {
+ my @params;
+ ($remote_file, @params) = @$remote_file;
+ for (@params) {
+ $type = $_ if s/^type=//;
+ }
+ }
+
+ if ($type && $type eq 'a') {
+ $ftp->ascii;
+ }
+ else {
+ $ftp->binary;
+ }
+
+ for (@path) {
+ unless ($ftp->cwd($_)) {
+ return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
+ "Can't chdir to $_");
+ }
+ }
+
+ if ($method eq 'GET' || $method eq 'HEAD') {
+ if (my $mod_time = $ftp->mdtm($remote_file)) {
+ $response->last_modified($mod_time);
+ if (my $ims = $request->if_modified_since) {
+ if ($mod_time <= $ims) {
+ $response->code(&HTTP::Status::RC_NOT_MODIFIED);
+ $response->message("Not modified");
+ return $response;
+ }
+ }
+ }
+
+ # We'll use this later to abort the transfer if necessary.
+ # if $max_size is defined, we need to abort early. Otherwise, it's
+ # a normal transfer
+ my $max_size = undef;
+
+ # Set resume location, if the client requested it
+ if ($request->header('Range') && $ftp->supported('REST'))
+ {
+ my $range_info = $request->header('Range');
+
+ # Change bytes=2772992-6781209 to just 2772992
+ my ($start_byte,$end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/;
+ if ( defined $start_byte && !defined $end_byte ) {
+
+ # open range -- only the start is specified
+
+ $ftp->restart( $start_byte );
+ # don't define $max_size, we don't want to abort early
+ }
+ elsif ( defined $start_byte && defined $end_byte &&
+ $start_byte >= 0 && $end_byte >= $start_byte ) {
+
+ $ftp->restart( $start_byte );
+ $max_size = $end_byte - $start_byte;
+ }
+ else {
+
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'Incorrect syntax for Range request');
+ }
+ }
+ elsif ($request->header('Range') && !$ftp->supported('REST'))
+ {
+ return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
+ "Server does not support resume.");
+ }
+
+ my $data; # the data handle
+ if (length($remote_file) and $data = $ftp->retr($remote_file)) {
+ my($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
+ $response->header('Content-Type', $type) if $type;
+ for (@enc) {
+ $response->push_header('Content-Encoding', $_);
+ }
+ my $mess = $ftp->message;
+ if ($mess =~ /\((\d+)\s+bytes\)/) {
+ $response->header('Content-Length', "$1");
+ }
+
+ if ($method ne 'HEAD') {
+ # Read data from server
+ $response = $self->collect($arg, $response, sub {
+ my $content = '';
+ my $result = $data->read($content, $size);
+
+ # Stop early if we need to.
+ if (defined $max_size)
+ {
+ # We need an interface to Net::FTP::dataconn for getting
+ # the number of bytes already read
+ my $bytes_received = $data->bytes_read();
+
+ # We were already over the limit. (Should only happen
+ # once at the end.)
+ if ($bytes_received - length($content) > $max_size)
+ {
+ $content = '';
+ }
+ # We just went over the limit
+ elsif ($bytes_received > $max_size)
+ {
+ # Trim content
+ $content = substr($content, 0,
+ $max_size - ($bytes_received - length($content)) );
+ }
+ # We're under the limit
+ else
+ {
+ }
+ }
+
+ return \$content;
+ } );
+ }
+ # abort is needed for HEAD, it's == close if the transfer has
+ # already completed.
+ unless ($data->abort) {
+ # Something did not work too well. Note that we treat
+ # responses to abort() with code 0 in case of HEAD as ok
+ # (at least wu-ftpd 2.6.1(1) does that).
+ if ($method ne 'HEAD' || $ftp->code != 0) {
+ $response->code(&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
+ $response->message("FTP close response: " . $ftp->code .
+ " " . $ftp->message);
+ }
+ }
+ }
+ elsif (!length($remote_file) || ( $ftp->code >= 400 && $ftp->code < 600 )) {
+ # not a plain file, try to list instead
+ if (length($remote_file) && !$ftp->cwd($remote_file)) {
+ return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
+ "File '$remote_file' not found");
+ }
+
+ # It should now be safe to try to list the directory
+ my @lsl = $ftp->dir;
+
+ # Try to figure out if the user want us to convert the
+ # directory listing to HTML.
+ my @variants =
+ (
+ ['html', 0.60, 'text/html' ],
+ ['dir', 1.00, 'text/ftp-dir-listing' ]
+ );
+ #$HTTP::Negotiate::DEBUG=1;
+ my $prefer = HTTP::Negotiate::choose(\@variants, $request);
+
+ my $content = '';
+
+ if (!defined($prefer)) {
+ return HTTP::Response->new(&HTTP::Status::RC_NOT_ACCEPTABLE,
+ "Neither HTML nor directory listing wanted");
+ }
+ elsif ($prefer eq 'html') {
+ $response->header('Content-Type' => 'text/html');
+ $content = "<HEAD><TITLE>File Listing</TITLE>\n";
+ my $base = $request->uri->clone;
+ my $path = $base->path;
+ $base->path("$path/") unless $path =~ m|/$|;
+ $content .= qq(<BASE HREF="$base">\n</HEAD>\n);
+ $content .= "<BODY>\n<UL>\n";
+ for (File::Listing::parse_dir(\@lsl, 'GMT')) {
+ my($name, $type, $size, $mtime, $mode) = @$_;
+ $content .= qq( <LI> <a href="$name">$name</a>);
+ $content .= " $size bytes" if $type eq 'f';
+ $content .= "\n";
+ }
+ $content .= "</UL></body>\n";
+ }
+ else {
+ $response->header('Content-Type', 'text/ftp-dir-listing');
+ $content = join("\n", @lsl, '');
+ }
+
+ $response->header('Content-Length', length($content));
+
+ if ($method ne 'HEAD') {
+ $response = $self->collect_once($arg, $response, $content);
+ }
+ }
+ else {
+ my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ "FTP return code " . $ftp->code);
+ $res->content_type("text/plain");
+ $res->content($ftp->message);
+ return $res;
+ }
+ }
+ elsif ($method eq 'PUT') {
+ # method must be PUT
+ unless (length($remote_file)) {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ "Must have a file name to PUT to");
+ }
+ my $data;
+ if ($data = $ftp->stor($remote_file)) {
+ my $content = $request->content;
+ my $bytes = 0;
+ if (defined $content) {
+ if (ref($content) eq 'SCALAR') {
+ $bytes = $data->write($$content, length($$content));
+ }
+ elsif (ref($content) eq 'CODE') {
+ my($buf, $n);
+ while (length($buf = &$content)) {
+ $n = $data->write($buf, length($buf));
+ last unless $n;
+ $bytes += $n;
+ }
+ }
+ elsif (!ref($content)) {
+ if (defined $content && length($content)) {
+ $bytes = $data->write($content, length($content));
+ }
+ }
+ else {
+ die "Bad content";
+ }
+ }
+ $data->close;
+
+ $response->code(&HTTP::Status::RC_CREATED);
+ $response->header('Content-Type', 'text/plain');
+ $response->content("$bytes bytes stored as $remote_file on $host\n")
+
+ }
+ else {
+ my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ "FTP return code " . $ftp->code);
+ $res->content_type("text/plain");
+ $res->content($ftp->message);
+ return $res;
+ }
+ }
+ else {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ "Illegal method $method");
+ }
+
+ $response;
+}
+
+1;
+
+__END__
+
+# This is what RFC 1738 has to say about FTP access:
+# --------------------------------------------------
+#
+# 3.2. FTP
+#
+# The FTP URL scheme is used to designate files and directories on
+# Internet hosts accessible using the FTP protocol (RFC959).
+#
+# A FTP URL follow the syntax described in Section 3.1. If :<port> is
+# omitted, the port defaults to 21.
+#
+# 3.2.1. FTP Name and Password
+#
+# A user name and password may be supplied; they are used in the ftp
+# "USER" and "PASS" commands after first making the connection to the
+# FTP server. If no user name or password is supplied and one is
+# requested by the FTP server, the conventions for "anonymous" FTP are
+# to be used, as follows:
+#
+# The user name "anonymous" is supplied.
+#
+# The password is supplied as the Internet e-mail address
+# of the end user accessing the resource.
+#
+# If the URL supplies a user name but no password, and the remote
+# server requests a password, the program interpreting the FTP URL
+# should request one from the user.
+#
+# 3.2.2. FTP url-path
+#
+# The url-path of a FTP URL has the following syntax:
+#
+# <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode>
+#
+# Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings
+# and <typecode> is one of the characters "a", "i", or "d". The part
+# ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be
+# empty. The whole url-path may be omitted, including the "/"
+# delimiting it from the prefix containing user, password, host, and
+# port.
+#
+# The url-path is interpreted as a series of FTP commands as follows:
+#
+# Each of the <cwd> elements is to be supplied, sequentially, as the
+# argument to a CWD (change working directory) command.
+#
+# If the typecode is "d", perform a NLST (name list) command with
+# <name> as the argument, and interpret the results as a file
+# directory listing.
+#
+# Otherwise, perform a TYPE command with <typecode> as the argument,
+# and then access the file whose name is <name> (for example, using
+# the RETR command.)
+#
+# Within a name or CWD component, the characters "/" and ";" are
+# reserved and must be encoded. The components are decoded prior to
+# their use in the FTP protocol. In particular, if the appropriate FTP
+# sequence to access a particular file requires supplying a string
+# containing a "/" as an argument to a CWD or RETR command, it is
+# necessary to encode each "/".
+#
+# For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is
+# interpreted by FTP-ing to "host.dom", logging in as "myname"
+# (prompting for a password if it is asked for), and then executing
+# "CWD /etc" and then "RETR motd". This has a different meaning from
+# <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then
+# "RETR motd"; the initial "CWD" might be executed relative to the
+# default directory for "myname". On the other hand,
+# <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null
+# argument, then "CWD etc", and then "RETR motd".
+#
+# FTP URLs may also be used for other operations; for example, it is
+# possible to update a file on a remote file server, or infer
+# information about it from the directory listings. The mechanism for
+# doing so is not spelled out here.
+#
+# 3.2.3. FTP Typecode is Optional
+#
+# The entire ;type=<typecode> part of a FTP URL is optional. If it is
+# omitted, the client program interpreting the URL must guess the
+# appropriate mode to use. In general, the data content type of a file
+# can only be guessed from the name, e.g., from the suffix of the name;
+# the appropriate type code to be used for transfer of the file can
+# then be deduced from the data content of the file.
+#
+# 3.2.4 Hierarchy
+#
+# For some file systems, the "/" used to denote the hierarchical
+# structure of the URL corresponds to the delimiter used to construct a
+# file name hierarchy, and thus, the filename will look similar to the
+# URL path. This does NOT mean that the URL is a Unix filename.
+#
+# 3.2.5. Optimization
+#
+# Clients accessing resources via FTP may employ additional heuristics
+# to optimize the interaction. For some FTP servers, for example, it
+# may be reasonable to keep the control connection open while accessing
+# multiple URLs from the same server. However, there is no common
+# hierarchical model to the FTP protocol, so if a directory change
+# command has been given, it is impossible in general to deduce what
+# sequence should be given to navigate to another directory for a
+# second retrieval, if the paths are different. The only reliable
+# algorithm is to disconnect and reestablish the control connection.
--- /dev/null
+package LWP::Protocol::gopher;
+
+# Implementation of the gopher protocol (RFC 1436)
+#
+# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
+# which in turn is a vastly modified version of Oscar's http'get()
+# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
+# including contributions from Marc van Heyningen and Martijn Koster.
+
+use strict;
+use vars qw(@ISA);
+
+require HTTP::Response;
+require HTTP::Status;
+require IO::Socket;
+require IO::Select;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+
+my %gopher2mimetype = (
+ '0' => 'text/plain', # 0 file
+ '1' => 'text/html', # 1 menu
+ # 2 CSO phone-book server
+ # 3 Error
+ '4' => 'application/mac-binhex40', # 4 BinHexed Macintosh file
+ '5' => 'application/zip', # 5 DOS binary archive of some sort
+ '6' => 'application/octet-stream', # 6 UNIX uuencoded file.
+ '7' => 'text/html', # 7 Index-Search server
+ # 8 telnet session
+ '9' => 'application/octet-stream', # 9 binary file
+ 'h' => 'text/html', # html
+ 'g' => 'image/gif', # gif
+ 'I' => 'image/*', # some kind of image
+);
+
+my %gopher2encoding = (
+ '6' => 'x_uuencode', # 6 UNIX uuencoded file.
+);
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+ $size = 4096 unless $size;
+
+ # check proxy
+ if (defined $proxy) {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy through the gopher');
+ }
+
+ my $url = $request->uri;
+ die "bad scheme" if $url->scheme ne 'gopher';
+
+
+ my $method = $request->method;
+ unless ($method eq 'GET' || $method eq 'HEAD') {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'gopher:' URLs");
+ }
+
+ my $gophertype = $url->gopher_type;
+ unless (exists $gopher2mimetype{$gophertype}) {
+ return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
+ 'Library does not support gophertype ' .
+ $gophertype);
+ }
+
+ my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+ $response->header('Content-type' => $gopher2mimetype{$gophertype}
+ || 'text/plain');
+ $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
+ if exists $gopher2encoding{$gophertype};
+
+ if ($method eq 'HEAD') {
+ # XXX: don't even try it so we set this header
+ $response->header('Client-Warning' => 'Client answer only');
+ return $response;
+ }
+
+ if ($gophertype eq '7' && ! $url->search) {
+ # the url is the prompt for a gopher search; supply boiler-plate
+ return $self->collect_once($arg, $response, <<"EOT");
+<HEAD>
+<TITLE>Gopher Index</TITLE>
+<ISINDEX>
+</HEAD>
+<BODY>
+<H1>$url<BR>Gopher Search</H1>
+This is a searchable Gopher index.
+Use the search function of your browser to enter search terms.
+</BODY>
+EOT
+ }
+
+ my $host = $url->host;
+ my $port = $url->port;
+
+ my $requestLine = "";
+
+ my $selector = $url->selector;
+ if (defined $selector) {
+ $requestLine .= $selector;
+ my $search = $url->search;
+ if (defined $search) {
+ $requestLine .= "\t$search";
+ my $string = $url->string;
+ if (defined $string) {
+ $requestLine .= "\t$string";
+ }
+ }
+ }
+ $requestLine .= "\015\012";
+
+ # potential request headers are just ignored
+
+ # Ok, lets make the request
+ my $socket = IO::Socket::INET->new(PeerAddr => $host,
+ PeerPort => $port,
+ LocalAddr => $self->{ua}{local_address},
+ Proto => 'tcp',
+ Timeout => $timeout);
+ die "Can't connect to $host:$port" unless $socket;
+ my $sel = IO::Select->new($socket);
+
+ {
+ die "write timeout" if $timeout && !$sel->can_write($timeout);
+ my $n = syswrite($socket, $requestLine, length($requestLine));
+ die $! unless defined($n);
+ die "short write" if $n != length($requestLine);
+ }
+
+ my $user_arg = $arg;
+
+ # must handle menus in a special way since they are to be
+ # converted to HTML. Undefing $arg ensures that the user does
+ # not see the data before we get a change to convert it.
+ $arg = undef if $gophertype eq '1' || $gophertype eq '7';
+
+ # collect response
+ my $buf = '';
+ $response = $self->collect($arg, $response, sub {
+ die "read timeout" if $timeout && !$sel->can_read($timeout);
+ my $n = sysread($socket, $buf, $size);
+ die $! unless defined($n);
+ return \$buf;
+ } );
+
+ # Convert menu to HTML and return data to user.
+ if ($gophertype eq '1' || $gophertype eq '7') {
+ my $content = menu2html($response->content);
+ if (defined $user_arg) {
+ $response = $self->collect_once($user_arg, $response, $content);
+ }
+ else {
+ $response->content($content);
+ }
+ }
+
+ $response;
+}
+
+
+sub gopher2url
+{
+ my($gophertype, $path, $host, $port) = @_;
+
+ my $url;
+
+ if ($gophertype eq '8' || $gophertype eq 'T') {
+ # telnet session
+ $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
+ $url->user($path) if defined $path;
+ }
+ else {
+ $path = URI::Escape::uri_escape($path);
+ $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
+ }
+ $url->host($host);
+ $url->port($port);
+ $url;
+}
+
+sub menu2html {
+ my($menu) = @_;
+
+ $menu =~ s/\015//g; # remove carriage return
+ my $tmp = <<"EOT";
+<HTML>
+<HEAD>
+ <TITLE>Gopher menu</TITLE>
+</HEAD>
+<BODY>
+<H1>Gopher menu</H1>
+EOT
+ for (split("\n", $menu)) {
+ last if /^\./;
+ my($pretty, $path, $host, $port) = split("\t");
+
+ $pretty =~ s/^(.)//;
+ my $type = $1;
+
+ my $url = gopher2url($type, $path, $host, $port)->as_string;
+ $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
+ }
+ $tmp .= "</BODY>\n</HTML>\n";
+ $tmp;
+}
+
+1;
--- /dev/null
+package LWP::Protocol::http;
+
+use strict;
+
+require HTTP::Response;
+require HTTP::Status;
+require Net::HTTP;
+
+use vars qw(@ISA @EXTRA_SOCK_OPTS);
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+my $CRLF = "\015\012";
+
+sub _new_socket
+{
+ my($self, $host, $port, $timeout) = @_;
+ my $conn_cache = $self->{ua}{conn_cache};
+ if ($conn_cache) {
+ if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
+ return $sock if $sock && !$sock->can_read(0);
+ # if the socket is readable, then either the peer has closed the
+ # connection or there are some garbage bytes on it. In either
+ # case we abandon it.
+ $sock->close;
+ }
+ }
+
+ local($^W) = 0; # IO::Socket::INET can be noisy
+ my $sock = $self->socket_class->new(PeerAddr => $host,
+ PeerPort => $port,
+ LocalAddr => $self->{ua}{local_address},
+ Proto => 'tcp',
+ Timeout => $timeout,
+ KeepAlive => !!$conn_cache,
+ SendTE => 1,
+ $self->_extra_sock_opts($host, $port),
+ );
+
+ unless ($sock) {
+ # IO::Socket::INET leaves additional error messages in $@
+ my $status = "Can't connect to $host:$port";
+ if ($@ =~ /\bconnect: (.*)/ ||
+ $@ =~ /\b(Bad hostname)\b/ ||
+ $@ =~ /\b(certificate verify failed)\b/ ||
+ $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
+ ) {
+ $status .= " ($1)";
+ }
+ die "$status\n\n$@";
+ }
+
+ # perl 5.005's IO::Socket does not have the blocking method.
+ eval { $sock->blocking(0); };
+
+ $sock;
+}
+
+sub socket_type
+{
+ return "http";
+}
+
+sub socket_class
+{
+ my $self = shift;
+ (ref($self) || $self) . "::Socket";
+}
+
+sub _extra_sock_opts # to be overridden by subclass
+{
+ return @EXTRA_SOCK_OPTS;
+}
+
+sub _check_sock
+{
+ #my($self, $req, $sock) = @_;
+}
+
+sub _get_sock_info
+{
+ my($self, $res, $sock) = @_;
+ if (defined(my $peerhost = $sock->peerhost)) {
+ $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
+ }
+}
+
+sub _fixup_header
+{
+ my($self, $h, $url, $proxy) = @_;
+
+ # Extract 'Host' header
+ my $hhost = $url->authority;
+ if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
+ # add authorization header if we need them. HTTP URLs do
+ # not really support specification of user and password, but
+ # we allow it.
+ if (defined($1) && not $h->header('Authorization')) {
+ require URI::Escape;
+ $h->authorization_basic(map URI::Escape::uri_unescape($_),
+ split(":", $1, 2));
+ }
+ }
+ $h->init_header('Host' => $hhost);
+
+ if ($proxy) {
+ # Check the proxy URI's userinfo() for proxy credentials
+ # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
+ my $p_auth = $proxy->userinfo();
+ if(defined $p_auth) {
+ require URI::Escape;
+ $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
+ split(":", $p_auth, 2))
+ }
+ }
+}
+
+sub hlist_remove {
+ my($hlist, $k) = @_;
+ $k = lc $k;
+ for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
+ next unless lc($hlist->[$i]) eq $k;
+ splice(@$hlist, $i, 2);
+ }
+}
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+ $size ||= 4096;
+
+ # check method
+ my $method = $request->method;
+ unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
+ return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'http:' URLs");
+ }
+
+ my $url = $request->uri;
+ my($host, $port, $fullpath);
+
+ # Check if we're proxy'ing
+ if (defined $proxy) {
+ # $proxy is an URL to an HTTP server which will proxy this request
+ $host = $proxy->host;
+ $port = $proxy->port;
+ $fullpath = $method eq "CONNECT" ?
+ ($url->host . ":" . $url->port) :
+ $url->as_string;
+ }
+ else {
+ $host = $url->host;
+ $port = $url->port;
+ $fullpath = $url->path_query;
+ $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
+ }
+
+ # connect to remote site
+ my $socket = $self->_new_socket($host, $port, $timeout);
+
+ my $http_version = "";
+ if (my $proto = $request->protocol) {
+ if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
+ $http_version = $1;
+ $socket->http_version($http_version);
+ $socket->send_te(0) if $http_version eq "1.0";
+ }
+ }
+
+ $self->_check_sock($request, $socket);
+
+ my @h;
+ my $request_headers = $request->headers->clone;
+ $self->_fixup_header($request_headers, $url, $proxy);
+
+ $request_headers->scan(sub {
+ my($k, $v) = @_;
+ $k =~ s/^://;
+ $v =~ s/\n/ /g;
+ push(@h, $k, $v);
+ });
+
+ my $content_ref = $request->content_ref;
+ $content_ref = $$content_ref if ref($$content_ref);
+ my $chunked;
+ my $has_content;
+
+ if (ref($content_ref) eq 'CODE') {
+ my $clen = $request_headers->header('Content-Length');
+ $has_content++ if $clen;
+ unless (defined $clen) {
+ push(@h, "Transfer-Encoding" => "chunked");
+ $has_content++;
+ $chunked++;
+ }
+ }
+ else {
+ # Set (or override) Content-Length header
+ my $clen = $request_headers->header('Content-Length');
+ if (defined($$content_ref) && length($$content_ref)) {
+ $has_content = length($$content_ref);
+ if (!defined($clen) || $clen ne $has_content) {
+ if (defined $clen) {
+ warn "Content-Length header value was wrong, fixed";
+ hlist_remove(\@h, 'Content-Length');
+ }
+ push(@h, 'Content-Length' => $has_content);
+ }
+ }
+ elsif ($clen) {
+ warn "Content-Length set when there is no content, fixed";
+ hlist_remove(\@h, 'Content-Length');
+ }
+ }
+
+ my $write_wait = 0;
+ $write_wait = 2
+ if ($request_headers->header("Expect") || "") =~ /100-continue/;
+
+ my $req_buf = $socket->format_request($method, $fullpath, @h);
+ #print "------\n$req_buf\n------\n";
+
+ if (!$has_content || $write_wait || $has_content > 8*1024) {
+ WRITE:
+ {
+ # Since this just writes out the header block it should almost
+ # always succeed to send the whole buffer in a single write call.
+ my $n = $socket->syswrite($req_buf, length($req_buf));
+ unless (defined $n) {
+ redo WRITE if $!{EINTR};
+ if ($!{EAGAIN}) {
+ select(undef, undef, undef, 0.1);
+ redo WRITE;
+ }
+ die "write failed: $!";
+ }
+ if ($n) {
+ substr($req_buf, 0, $n, "");
+ }
+ else {
+ select(undef, undef, undef, 0.5);
+ }
+ redo WRITE if length $req_buf;
+ }
+ }
+
+ my($code, $mess, @junk);
+ my $drop_connection;
+
+ if ($has_content) {
+ my $eof;
+ my $wbuf;
+ my $woffset = 0;
+ INITIAL_READ:
+ if ($write_wait) {
+ # skip filling $wbuf when waiting for 100-continue
+ # because if the response is a redirect or auth required
+ # the request will be cloned and there is no way
+ # to reset the input stream
+ # return here via the label after the 100-continue is read
+ }
+ elsif (ref($content_ref) eq 'CODE') {
+ my $buf = &$content_ref();
+ $buf = "" unless defined($buf);
+ $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
+ if $chunked;
+ substr($buf, 0, 0) = $req_buf if $req_buf;
+ $wbuf = \$buf;
+ }
+ else {
+ if ($req_buf) {
+ my $buf = $req_buf . $$content_ref;
+ $wbuf = \$buf;
+ }
+ else {
+ $wbuf = $content_ref;
+ }
+ $eof = 1;
+ }
+
+ my $fbits = '';
+ vec($fbits, fileno($socket), 1) = 1;
+
+ WRITE:
+ while ($write_wait || $woffset < length($$wbuf)) {
+
+ my $sel_timeout = $timeout;
+ if ($write_wait) {
+ $sel_timeout = $write_wait if $write_wait < $sel_timeout;
+ }
+ my $time_before;
+ $time_before = time if $sel_timeout;
+
+ my $rbits = $fbits;
+ my $wbits = $write_wait ? undef : $fbits;
+ my $sel_timeout_before = $sel_timeout;
+ SELECT:
+ {
+ my $nfound = select($rbits, $wbits, undef, $sel_timeout);
+ if ($nfound < 0) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ if ($time_before) {
+ $sel_timeout = $sel_timeout_before - (time - $time_before);
+ $sel_timeout = 0 if $sel_timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
+ }
+
+ if ($write_wait) {
+ $write_wait -= time - $time_before;
+ $write_wait = 0 if $write_wait < 0;
+ }
+
+ if (defined($rbits) && $rbits =~ /[^\0]/) {
+ # readable
+ my $buf = $socket->_rbuf;
+ my $n = $socket->sysread($buf, 1024, length($buf));
+ unless (defined $n) {
+ die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
+ # if we get here the rest of the block will do nothing
+ # and we will retry the read on the next round
+ }
+ elsif ($n == 0) {
+ # the server closed the connection before we finished
+ # writing all the request content. No need to write any more.
+ $drop_connection++;
+ last WRITE;
+ }
+ $socket->_rbuf($buf);
+ if (!$code && $buf =~ /\015?\012\015?\012/) {
+ # a whole response header is present, so we can read it without blocking
+ ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
+ junk_out => \@junk,
+ );
+ if ($code eq "100") {
+ $write_wait = 0;
+ undef($code);
+ goto INITIAL_READ;
+ }
+ else {
+ $drop_connection++;
+ last WRITE;
+ # XXX should perhaps try to abort write in a nice way too
+ }
+ }
+ }
+ if (defined($wbits) && $wbits =~ /[^\0]/) {
+ my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
+ unless (defined $n) {
+ die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
+ $n = 0; # will retry write on the next round
+ }
+ elsif ($n == 0) {
+ die "write failed: no bytes written";
+ }
+ $woffset += $n;
+
+ if (!$eof && $woffset >= length($$wbuf)) {
+ # need to refill buffer from $content_ref code
+ my $buf = &$content_ref();
+ $buf = "" unless defined($buf);
+ $eof++ unless length($buf);
+ $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
+ if $chunked;
+ $wbuf = \$buf;
+ $woffset = 0;
+ }
+ }
+ } # WRITE
+ }
+
+ ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
+ unless $code;
+ ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
+ if $code eq "100";
+
+ my $response = HTTP::Response->new($code, $mess);
+ my $peer_http_version = $socket->peer_http_version;
+ $response->protocol("HTTP/$peer_http_version");
+ {
+ local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+ $response->push_header(@h);
+ }
+ $response->push_header("Client-Junk" => \@junk) if @junk;
+
+ $response->request($request);
+ $self->_get_sock_info($response, $socket);
+
+ if ($method eq "CONNECT") {
+ $response->{client_socket} = $socket; # so it can be picked up
+ return $response;
+ }
+
+ if (my @te = $response->remove_header('Transfer-Encoding')) {
+ $response->push_header('Client-Transfer-Encoding', \@te);
+ }
+ $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
+
+ my $complete;
+ $response = $self->collect($arg, $response, sub {
+ my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
+ my $n;
+ READ:
+ {
+ $n = $socket->read_entity_body($buf, $size);
+ unless (defined $n) {
+ redo READ if $!{EINTR} || $!{EAGAIN};
+ die "read failed: $!";
+ }
+ redo READ if $n == -1;
+ }
+ $complete++ if !$n;
+ return \$buf;
+ } );
+ $drop_connection++ unless $complete;
+
+ @h = $socket->get_trailers;
+ if (@h) {
+ local $HTTP::Headers::TRANSLATE_UNDERSCORE;
+ $response->push_header(@h);
+ }
+
+ # keep-alive support
+ unless ($drop_connection) {
+ if (my $conn_cache = $self->{ua}{conn_cache}) {
+ my %connection = map { (lc($_) => 1) }
+ split(/\s*,\s*/, ($response->header("Connection") || ""));
+ if (($peer_http_version eq "1.1" && !$connection{close}) ||
+ $connection{"keep-alive"})
+ {
+ $conn_cache->deposit($self->socket_type, "$host:$port", $socket);
+ }
+ }
+ }
+
+ $response;
+}
+
+
+#-----------------------------------------------------------
+package LWP::Protocol::http::SocketMethods;
+
+sub sysread {
+ my $self = shift;
+ if (my $timeout = ${*$self}{io_socket_timeout}) {
+ die "read timeout" unless $self->can_read($timeout);
+ }
+ else {
+ # since we have made the socket non-blocking we
+ # use select to wait for some data to arrive
+ $self->can_read(undef) || die "Assert";
+ }
+ sysread($self, $_[0], $_[1], $_[2] || 0);
+}
+
+sub can_read {
+ my($self, $timeout) = @_;
+ my $fbits = '';
+ vec($fbits, fileno($self), 1) = 1;
+ SELECT:
+ {
+ my $before;
+ $before = time if $timeout;
+ my $nfound = select($fbits, undef, undef, $timeout);
+ if ($nfound < 0) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ # don't really think EAGAIN can happen here
+ if ($timeout) {
+ $timeout -= time - $before;
+ $timeout = 0 if $timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
+ return $nfound > 0;
+ }
+}
+
+sub ping {
+ my $self = shift;
+ !$self->can_read(0);
+}
+
+sub increment_response_count {
+ my $self = shift;
+ return ++${*$self}{'myhttp_response_count'};
+}
+
+#-----------------------------------------------------------
+package LWP::Protocol::http::Socket;
+use vars qw(@ISA);
+@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
+
+1;
--- /dev/null
+package LWP::Protocol::loopback;
+
+use strict;
+use vars qw(@ISA);
+require HTTP::Response;
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+sub request {
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+ my $response = HTTP::Response->new(200, "OK");
+ $response->content_type("message/http; msgtype=request");
+
+ $response->header("Via", "loopback/1.0 $proxy")
+ if $proxy;
+
+ $response->header("X-Arg", $arg);
+ $response->header("X-Read-Size", $size);
+ $response->header("X-Timeout", $timeout);
+
+ return $self->collect_once($arg, $response, $request->as_string);
+}
+
+1;
--- /dev/null
+package LWP::Protocol::mailto;
+
+# This module implements the mailto protocol. It is just a simple
+# frontend to the Unix sendmail program except on MacOS, where it uses
+# Mail::Internet.
+
+require LWP::Protocol;
+require HTTP::Request;
+require HTTP::Response;
+require HTTP::Status;
+
+use Carp;
+use strict;
+use vars qw(@ISA $SENDMAIL);
+
+@ISA = qw(LWP::Protocol);
+
+unless ($SENDMAIL = $ENV{SENDMAIL}) {
+ for my $sm (qw(/usr/sbin/sendmail
+ /usr/lib/sendmail
+ /usr/ucblib/sendmail
+ ))
+ {
+ if (-x $sm) {
+ $SENDMAIL = $sm;
+ last;
+ }
+ }
+ die "Can't find the 'sendmail' program" unless $SENDMAIL;
+}
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size) = @_;
+
+ my ($mail, $addr) if $^O eq "MacOS";
+ my @text = () if $^O eq "MacOS";
+
+ # check proxy
+ if (defined $proxy)
+ {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy with mail');
+ }
+
+ # check method
+ my $method = $request->method;
+
+ if ($method ne 'POST') {
+ return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'mailto:' URLs");
+ }
+
+ # check url
+ my $url = $request->uri;
+
+ my $scheme = $url->scheme;
+ if ($scheme ne 'mailto') {
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "LWP::Protocol::mailto::request called for '$scheme'");
+ }
+ if ($^O eq "MacOS") {
+ eval {
+ require Mail::Internet;
+ };
+ if($@) {
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "You don't have MailTools installed");
+ }
+ unless ($ENV{SMTPHOSTS}) {
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "You don't have SMTPHOSTS defined");
+ }
+ }
+ else {
+ unless (-x $SENDMAIL) {
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "You don't have $SENDMAIL");
+ }
+ }
+ if ($^O eq "MacOS") {
+ $mail = Mail::Internet->new or
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "Can't get a Mail::Internet object");
+ }
+ else {
+ open(SENDMAIL, "| $SENDMAIL -oi -t") or
+ return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "Can't run $SENDMAIL: $!");
+ }
+ if ($^O eq "MacOS") {
+ $addr = $url->encoded822addr;
+ }
+ else {
+ $request = $request->clone; # we modify a copy
+ my @h = $url->headers; # URL headers override those in the request
+ while (@h) {
+ my $k = shift @h;
+ my $v = shift @h;
+ next unless defined $v;
+ if (lc($k) eq "body") {
+ $request->content($v);
+ }
+ else {
+ $request->push_header($k => $v);
+ }
+ }
+ }
+ if ($^O eq "MacOS") {
+ $mail->add(To => $addr);
+ $mail->add(split(/[:\n]/,$request->headers_as_string));
+ }
+ else {
+ print SENDMAIL $request->headers_as_string;
+ print SENDMAIL "\n";
+ }
+ my $content = $request->content;
+ if (defined $content) {
+ my $contRef = ref($content) ? $content : \$content;
+ if (ref($contRef) eq 'SCALAR') {
+ if ($^O eq "MacOS") {
+ @text = split("\n",$$contRef);
+ foreach (@text) {
+ $_ .= "\n";
+ }
+ }
+ else {
+ print SENDMAIL $$contRef;
+ }
+
+ }
+ elsif (ref($contRef) eq 'CODE') {
+ # Callback provides data
+ my $d;
+ if ($^O eq "MacOS") {
+ my $stuff = "";
+ while (length($d = &$contRef)) {
+ $stuff .= $d;
+ }
+ @text = split("\n",$stuff);
+ foreach (@text) {
+ $_ .= "\n";
+ }
+ }
+ else {
+ print SENDMAIL $d;
+ }
+ }
+ }
+ if ($^O eq "MacOS") {
+ $mail->body(\@text);
+ unless ($mail->smtpsend) {
+ return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "Mail::Internet->smtpsend unable to send message to <$addr>");
+ }
+ }
+ else {
+ unless (close(SENDMAIL)) {
+ my $err = $! ? "$!" : "Exit status $?";
+ return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "$SENDMAIL: $err");
+ }
+ }
+
+
+ my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
+ "Mail accepted");
+ $response->header('Content-Type', 'text/plain');
+ if ($^O eq "MacOS") {
+ $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
+ $response->content("Message sent to <$addr>\n");
+ }
+ else {
+ $response->header('Server' => $SENDMAIL);
+ my $to = $request->header("To");
+ $response->content("Message sent to <$to>\n");
+ }
+
+ return $response;
+}
+
+1;
--- /dev/null
+package LWP::Protocol::nntp;
+
+# Implementation of the Network News Transfer Protocol (RFC 977)
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require HTTP::Response;
+require HTTP::Status;
+require Net::NNTP;
+
+use strict;
+
+
+sub request
+{
+ my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+ $size = 4096 unless $size;
+
+ # Check for proxy
+ if (defined $proxy) {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy through NNTP');
+ }
+
+ # Check that the scheme is as expected
+ my $url = $request->uri;
+ my $scheme = $url->scheme;
+ unless ($scheme eq 'news' || $scheme eq 'nntp') {
+ return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "LWP::Protocol::nntp::request called for '$scheme'");
+ }
+
+ # check for a valid method
+ my $method = $request->method;
+ unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for '$scheme:' URLs");
+ }
+
+ # extract the identifier and check against posting to an article
+ my $groupart = $url->_group;
+ my $is_art = $groupart =~ /@/;
+
+ if ($is_art && $method eq 'POST') {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ "Can't post to an article <$groupart>");
+ }
+
+ my $nntp = Net::NNTP->new($url->host,
+ #Port => 18574,
+ Timeout => $timeout,
+ #Debug => 1,
+ );
+ die "Can't connect to nntp server" unless $nntp;
+
+ # Check the initial welcome message from the NNTP server
+ if ($nntp->status != 2) {
+ return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
+ $nntp->message);
+ }
+ my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+
+ my $mess = $nntp->message;
+
+ # Try to extract server name from greeting message.
+ # Don't know if this works well for a large class of servers, but
+ # this works for our server.
+ $mess =~ s/\s+ready\b.*//;
+ $mess =~ s/^\S+\s+//;
+ $response->header(Server => $mess);
+
+ # First we handle posting of articles
+ if ($method eq 'POST') {
+ $nntp->quit; $nntp = undef;
+ $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+ $response->message("POST not implemented yet");
+ return $response;
+ }
+
+ # The method must be "GET" or "HEAD" by now
+ if (!$is_art) {
+ if (!$nntp->group($groupart)) {
+ $response->code(&HTTP::Status::RC_NOT_FOUND);
+ $response->message($nntp->message);
+ }
+ $nntp->quit; $nntp = undef;
+ # HEAD: just check if the group exists
+ if ($method eq 'GET' && $response->is_success) {
+ $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+ $response->message("GET newsgroup not implemented yet");
+ }
+ return $response;
+ }
+
+ # Send command to server to retrieve an article (or just the headers)
+ my $get = $method eq 'HEAD' ? "head" : "article";
+ my $art = $nntp->$get("<$groupart>");
+ unless ($art) {
+ $nntp->quit; $nntp = undef;
+ $response->code(&HTTP::Status::RC_NOT_FOUND);
+ $response->message($nntp->message);
+ return $response;
+ }
+
+ # Parse headers
+ my($key, $val);
+ local $_;
+ while ($_ = shift @$art) {
+ if (/^\s+$/) {
+ last; # end of headers
+ }
+ elsif (/^(\S+):\s*(.*)/) {
+ $response->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ next unless $key;
+ $val .= $1;
+ }
+ else {
+ unshift(@$art, $_);
+ last;
+ }
+ }
+ $response->push_header($key, $val) if $key;
+
+ # Ensure that there is a Content-Type header
+ $response->header("Content-Type", "text/plain")
+ unless $response->header("Content-Type");
+
+ # Collect the body
+ $response = $self->collect_once($arg, $response, join("", @$art))
+ if @$art;
+
+ # Say goodbye to the server
+ $nntp->quit;
+ $nntp = undef;
+
+ $response;
+}
+
+1;
--- /dev/null
+package LWP::Protocol::nogo;
+# If you want to disable access to a particular scheme, use this
+# class and then call
+# LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo');
+# For then on, attempts to access URLs with that scheme will generate
+# a 500 error.
+
+use strict;
+use vars qw(@ISA);
+require HTTP::Response;
+require HTTP::Status;
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+sub request {
+ my($self, $request) = @_;
+ my $scheme = $request->uri->scheme;
+
+ return HTTP::Response->new(
+ &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ "Access to \'$scheme\' URIs has been disabled"
+ );
+}
+1;
--- /dev/null
+package LWP::RobotUA;
+
+require LWP::UserAgent;
+@ISA = qw(LWP::UserAgent);
+$VERSION = "6.03";
+
+require WWW::RobotRules;
+require HTTP::Request;
+require HTTP::Response;
+
+use Carp ();
+use HTTP::Status ();
+use HTTP::Date qw(time2str);
+use strict;
+
+
+#
+# Additional attributes in addition to those found in LWP::UserAgent:
+#
+# $self->{'delay'} Required delay between request to the same
+# server in minutes.
+#
+# $self->{'rules'} A WWW::RobotRules object
+#
+
+sub new
+{
+ my $class = shift;
+ my %cnf;
+ if (@_ < 4) {
+ # legacy args
+ @cnf{qw(agent from rules)} = @_;
+ }
+ else {
+ %cnf = @_;
+ }
+
+ Carp::croak('LWP::RobotUA agent required') unless $cnf{agent};
+ Carp::croak('LWP::RobotUA from address required')
+ unless $cnf{from} && $cnf{from} =~ m/\@/;
+
+ my $delay = delete $cnf{delay} || 1;
+ my $use_sleep = delete $cnf{use_sleep};
+ $use_sleep = 1 unless defined($use_sleep);
+ my $rules = delete $cnf{rules};
+
+ my $self = LWP::UserAgent->new(%cnf);
+ $self = bless $self, $class;
+
+ $self->{'delay'} = $delay; # minutes
+ $self->{'use_sleep'} = $use_sleep;
+
+ if ($rules) {
+ $rules->agent($cnf{agent});
+ $self->{'rules'} = $rules;
+ }
+ else {
+ $self->{'rules'} = WWW::RobotRules->new($cnf{agent});
+ }
+
+ $self;
+}
+
+
+sub delay { shift->_elem('delay', @_); }
+sub use_sleep { shift->_elem('use_sleep', @_); }
+
+
+sub agent
+{
+ my $self = shift;
+ my $old = $self->SUPER::agent(@_);
+ if (@_) {
+ # Changing our name means to start fresh
+ $self->{'rules'}->agent($self->{'agent'});
+ }
+ $old;
+}
+
+
+sub rules {
+ my $self = shift;
+ my $old = $self->_elem('rules', @_);
+ $self->{'rules'}->agent($self->{'agent'}) if @_;
+ $old;
+}
+
+
+sub no_visits
+{
+ my($self, $netloc) = @_;
+ $self->{'rules'}->no_visits($netloc) || 0;
+}
+
+*host_count = \&no_visits; # backwards compatibility with LWP-5.02
+
+
+sub host_wait
+{
+ my($self, $netloc) = @_;
+ return undef unless defined $netloc;
+ my $last = $self->{'rules'}->last_visit($netloc);
+ if ($last) {
+ my $wait = int($self->{'delay'} * 60 - (time - $last));
+ $wait = 0 if $wait < 0;
+ return $wait;
+ }
+ return 0;
+}
+
+
+sub simple_request
+{
+ my($self, $request, $arg, $size) = @_;
+
+ # Do we try to access a new server?
+ my $allowed = $self->{'rules'}->allowed($request->uri);
+
+ if ($allowed < 0) {
+ # Host is not visited before, or robots.txt expired; fetch "robots.txt"
+ my $robot_url = $request->uri->clone;
+ $robot_url->path("robots.txt");
+ $robot_url->query(undef);
+
+ # make access to robot.txt legal since this will be a recursive call
+ $self->{'rules'}->parse($robot_url, "");
+
+ my $robot_req = HTTP::Request->new('GET', $robot_url);
+ my $parse_head = $self->parse_head(0);
+ my $robot_res = $self->request($robot_req);
+ $self->parse_head($parse_head);
+ my $fresh_until = $robot_res->fresh_until;
+ my $content = "";
+ if ($robot_res->is_success && $robot_res->content_is_text) {
+ $content = $robot_res->decoded_content;
+ $content = "" unless $content && $content =~ /^\s*Disallow\s*:/mi;
+ }
+ $self->{'rules'}->parse($robot_url, $content, $fresh_until);
+
+ # recalculate allowed...
+ $allowed = $self->{'rules'}->allowed($request->uri);
+ }
+
+ # Check rules
+ unless ($allowed) {
+ my $res = HTTP::Response->new(
+ &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt');
+ $res->request( $request ); # bind it to that request
+ return $res;
+ }
+
+ my $netloc = eval { local $SIG{__DIE__}; $request->uri->host_port; };
+ my $wait = $self->host_wait($netloc);
+
+ if ($wait) {
+ if ($self->{'use_sleep'}) {
+ sleep($wait)
+ }
+ else {
+ my $res = HTTP::Response->new(
+ &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down');
+ $res->header('Retry-After', time2str(time + $wait));
+ $res->request( $request ); # bind it to that request
+ return $res;
+ }
+ }
+
+ # Perform the request
+ my $res = $self->SUPER::simple_request($request, $arg, $size);
+
+ $self->{'rules'}->visit($netloc);
+
+ $res;
+}
+
+
+sub as_string
+{
+ my $self = shift;
+ my @s;
+ push(@s, "Robot: $self->{'agent'} operated by $self->{'from'} [$self]");
+ push(@s, " Minimum delay: " . int($self->{'delay'}*60) . "s");
+ push(@s, " Will sleep if too early") if $self->{'use_sleep'};
+ push(@s, " Rules = $self->{'rules'}");
+ join("\n", @s, '');
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+LWP::RobotUA - a class for well-behaved Web robots
+
+=head1 SYNOPSIS
+
+ use LWP::RobotUA;
+ my $ua = LWP::RobotUA->new('my-robot/0.1', 'me@foo.com');
+ $ua->delay(10); # be very nice -- max one hit every ten minutes!
+ ...
+
+ # Then just use it just like a normal LWP::UserAgent:
+ my $response = $ua->get('http://whatever.int/...');
+ ...
+
+=head1 DESCRIPTION
+
+This class implements a user agent that is suitable for robot
+applications. Robots should be nice to the servers they visit. They
+should consult the F</robots.txt> file to ensure that they are welcomed
+and they should not make requests too frequently.
+
+But before you consider writing a robot, take a look at
+<URL:http://www.robotstxt.org/>.
+
+When you use a I<LWP::RobotUA> object as your user agent, then you do not
+really have to think about these things yourself; C<robots.txt> files
+are automatically consulted and obeyed, the server isn't queried
+too rapidly, and so on. Just send requests
+as you do when you are using a normal I<LWP::UserAgent>
+object (using C<< $ua->get(...) >>, C<< $ua->head(...) >>,
+C<< $ua->request(...) >>, etc.), and this
+special agent will make sure you are nice.
+
+=head1 METHODS
+
+The LWP::RobotUA is a sub-class of LWP::UserAgent and implements the
+same methods. In addition the following methods are provided:
+
+=over 4
+
+=item $ua = LWP::RobotUA->new( %options )
+
+=item $ua = LWP::RobotUA->new( $agent, $from )
+
+=item $ua = LWP::RobotUA->new( $agent, $from, $rules )
+
+The LWP::UserAgent options C<agent> and C<from> are mandatory. The
+options C<delay>, C<use_sleep> and C<rules> initialize attributes
+private to the RobotUA. If C<rules> are not provided, then
+C<WWW::RobotRules> is instantiated providing an internal database of
+F<robots.txt>.
+
+It is also possible to just pass the value of C<agent>, C<from> and
+optionally C<rules> as plain positional arguments.
+
+=item $ua->delay
+
+=item $ua->delay( $minutes )
+
+Get/set the minimum delay between requests to the same server, in
+I<minutes>. The default is 1 minute. Note that this number doesn't
+have to be an integer; for example, this sets the delay to 10 seconds:
+
+ $ua->delay(10/60);
+
+=item $ua->use_sleep
+
+=item $ua->use_sleep( $boolean )
+
+Get/set a value indicating whether the UA should sleep() if requests
+arrive too fast, defined as $ua->delay minutes not passed since
+last request to the given server. The default is TRUE. If this value is
+FALSE then an internal SERVICE_UNAVAILABLE response will be generated.
+It will have an Retry-After header that indicates when it is OK to
+send another request to this server.
+
+=item $ua->rules
+
+=item $ua->rules( $rules )
+
+Set/get which I<WWW::RobotRules> object to use.
+
+=item $ua->no_visits( $netloc )
+
+Returns the number of documents fetched from this server host. Yeah I
+know, this method should probably have been named num_visits() or
+something like that. :-(
+
+=item $ua->host_wait( $netloc )
+
+Returns the number of I<seconds> (from now) you must wait before you can
+make a new request to this host.
+
+=item $ua->as_string
+
+Returns a string that describes the state of the UA.
+Mainly useful for debugging.
+
+=back
+
+=head1 SEE ALSO
+
+L<LWP::UserAgent>, L<WWW::RobotRules>
+
+=head1 COPYRIGHT
+
+Copyright 1996-2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
--- /dev/null
+package LWP::Simple;
+
+use strict;
+use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
+
+require Exporter;
+
+@EXPORT = qw(get head getprint getstore mirror);
+@EXPORT_OK = qw($ua);
+
+# I really hate this. I was a bad idea to do it in the first place.
+# Wonder how to get rid of it??? (It even makes LWP::Simple 7% slower
+# for trivial tests)
+use HTTP::Status;
+push(@EXPORT, @HTTP::Status::EXPORT);
+
+$VERSION = "6.00";
+
+sub import
+{
+ my $pkg = shift;
+ my $callpkg = caller;
+ Exporter::export($pkg, $callpkg, @_);
+}
+
+use LWP::UserAgent ();
+use HTTP::Status ();
+use HTTP::Date ();
+$ua = LWP::UserAgent->new; # we create a global UserAgent object
+$ua->agent("LWP::Simple/$VERSION ");
+$ua->env_proxy;
+
+
+sub get ($)
+{
+ my $response = $ua->get(shift);
+ return $response->decoded_content if $response->is_success;
+ return undef;
+}
+
+
+sub head ($)
+{
+ my($url) = @_;
+ my $request = HTTP::Request->new(HEAD => $url);
+ my $response = $ua->request($request);
+
+ if ($response->is_success) {
+ return $response unless wantarray;
+ return (scalar $response->header('Content-Type'),
+ scalar $response->header('Content-Length'),
+ HTTP::Date::str2time($response->header('Last-Modified')),
+ HTTP::Date::str2time($response->header('Expires')),
+ scalar $response->header('Server'),
+ );
+ }
+ return;
+}
+
+
+sub getprint ($)
+{
+ my($url) = @_;
+ my $request = HTTP::Request->new(GET => $url);
+ local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
+ my $callback = sub { print $_[0] };
+ if ($^O eq "MacOS") {
+ $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
+ }
+ my $response = $ua->request($request, $callback);
+ unless ($response->is_success) {
+ print STDERR $response->status_line, " <URL:$url>\n";
+ }
+ $response->code;
+}
+
+
+sub getstore ($$)
+{
+ my($url, $file) = @_;
+ my $request = HTTP::Request->new(GET => $url);
+ my $response = $ua->request($request, $file);
+
+ $response->code;
+}
+
+
+sub mirror ($$)
+{
+ my($url, $file) = @_;
+ my $response = $ua->mirror($url, $file);
+ $response->code;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::Simple - simple procedural interface to LWP
+
+=head1 SYNOPSIS
+
+ perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
+
+ use LWP::Simple;
+ $content = get("http://www.sn.no/");
+ die "Couldn't get it!" unless defined $content;
+
+ if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
+ ...
+ }
+
+ if (is_success(getprint("http://www.sn.no/"))) {
+ ...
+ }
+
+=head1 DESCRIPTION
+
+This module is meant for people who want a simplified view of the
+libwww-perl library. It should also be suitable for one-liners. If
+you need more control or access to the header fields in the requests
+sent and responses received, then you should use the full object-oriented
+interface provided by the C<LWP::UserAgent> module.
+
+The following functions are provided (and exported) by this module:
+
+=over 3
+
+=item get($url)
+
+The get() function will fetch the document identified by the given URL
+and return it. It returns C<undef> if it fails. The $url argument can
+be either a string or a reference to a URI object.
+
+You will not be able to examine the response code or response headers
+(like 'Content-Type') when you are accessing the web using this
+function. If you need that information you should use the full OO
+interface (see L<LWP::UserAgent>).
+
+=item head($url)
+
+Get document headers. Returns the following 5 values if successful:
+($content_type, $document_length, $modified_time, $expires, $server)
+
+Returns an empty list if it fails. In scalar context returns TRUE if
+successful.
+
+=item getprint($url)
+
+Get and print a document identified by a URL. The document is printed
+to the selected default filehandle for output (normally STDOUT) as
+data is received from the network. If the request fails, then the
+status code and message are printed on STDERR. The return value is
+the HTTP response code.
+
+=item getstore($url, $file)
+
+Gets a document identified by a URL and stores it in the file. The
+return value is the HTTP response code.
+
+=item mirror($url, $file)
+
+Get and store a document identified by a URL, using
+I<If-modified-since>, and checking the I<Content-Length>. Returns
+the HTTP response code.
+
+=back
+
+This module also exports the HTTP::Status constants and procedures.
+You can use them when you check the response code from getprint(),
+getstore() or mirror(). The constants are:
+
+ RC_CONTINUE
+ RC_SWITCHING_PROTOCOLS
+ RC_OK
+ RC_CREATED
+ RC_ACCEPTED
+ RC_NON_AUTHORITATIVE_INFORMATION
+ RC_NO_CONTENT
+ RC_RESET_CONTENT
+ RC_PARTIAL_CONTENT
+ RC_MULTIPLE_CHOICES
+ RC_MOVED_PERMANENTLY
+ RC_MOVED_TEMPORARILY
+ RC_SEE_OTHER
+ RC_NOT_MODIFIED
+ RC_USE_PROXY
+ RC_BAD_REQUEST
+ RC_UNAUTHORIZED
+ RC_PAYMENT_REQUIRED
+ RC_FORBIDDEN
+ RC_NOT_FOUND
+ RC_METHOD_NOT_ALLOWED
+ RC_NOT_ACCEPTABLE
+ RC_PROXY_AUTHENTICATION_REQUIRED
+ RC_REQUEST_TIMEOUT
+ RC_CONFLICT
+ RC_GONE
+ RC_LENGTH_REQUIRED
+ RC_PRECONDITION_FAILED
+ RC_REQUEST_ENTITY_TOO_LARGE
+ RC_REQUEST_URI_TOO_LARGE
+ RC_UNSUPPORTED_MEDIA_TYPE
+ RC_INTERNAL_SERVER_ERROR
+ RC_NOT_IMPLEMENTED
+ RC_BAD_GATEWAY
+ RC_SERVICE_UNAVAILABLE
+ RC_GATEWAY_TIMEOUT
+ RC_HTTP_VERSION_NOT_SUPPORTED
+
+The HTTP::Status classification functions are:
+
+=over 3
+
+=item is_success($rc)
+
+True if response code indicated a successful request.
+
+=item is_error($rc)
+
+True if response code indicated that an error occurred.
+
+=back
+
+The module will also export the LWP::UserAgent object as C<$ua> if you
+ask for it explicitly.
+
+The user agent created by this module will identify itself as
+"LWP::Simple/#.##"
+and will initialize its proxy defaults from the environment (by
+calling $ua->env_proxy).
+
+=head1 CAVEAT
+
+Note that if you are using both LWP::Simple and the very popular CGI.pm
+module, you may be importing a C<head> function from each module,
+producing a warning like "Prototype mismatch: sub main::head ($) vs
+none". Get around this problem by just not importing LWP::Simple's
+C<head> function, like so:
+
+ use LWP::Simple qw(!head);
+ use CGI qw(:standard); # then only CGI.pm defines a head()
+
+Then if you do need LWP::Simple's C<head> function, you can just call
+it as C<LWP::Simple::head($url)>.
+
+=head1 SEE ALSO
+
+L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
+L<lwp-mirror>
--- /dev/null
+package LWP::UserAgent;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+require LWP::MemberMixin;
+@ISA = qw(LWP::MemberMixin);
+$VERSION = "6.04";
+
+use HTTP::Request ();
+use HTTP::Response ();
+use HTTP::Date ();
+
+use LWP ();
+use LWP::Protocol ();
+
+use Carp ();
+
+
+sub new
+{
+ # Check for common user mistake
+ Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
+ if ref($_[1]) eq 'HASH';
+
+ my($class, %cnf) = @_;
+
+ my $agent = delete $cnf{agent};
+ my $from = delete $cnf{from};
+ my $def_headers = delete $cnf{default_headers};
+ my $timeout = delete $cnf{timeout};
+ $timeout = 3*60 unless defined $timeout;
+ my $local_address = delete $cnf{local_address};
+ my $ssl_opts = delete $cnf{ssl_opts} || {};
+ unless (exists $ssl_opts->{verify_hostname}) {
+ # The processing of HTTPS_CA_* below is for compatiblity with Crypt::SSLeay
+ if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) {
+ $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
+ }
+ elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) {
+ # Crypt-SSLeay compatiblity (verify peer certificate; but not the hostname)
+ $ssl_opts->{verify_hostname} = 0;
+ $ssl_opts->{SSL_verify_mode} = 1;
+ }
+ else {
+ $ssl_opts->{verify_hostname} = 1;
+ }
+ }
+ unless (exists $ssl_opts->{SSL_ca_file}) {
+ if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
+ $ssl_opts->{SSL_ca_file} = $ca_file;
+ }
+ }
+ unless (exists $ssl_opts->{SSL_ca_path}) {
+ if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
+ $ssl_opts->{SSL_ca_path} = $ca_path;
+ }
+ }
+ my $use_eval = delete $cnf{use_eval};
+ $use_eval = 1 unless defined $use_eval;
+ my $parse_head = delete $cnf{parse_head};
+ $parse_head = 1 unless defined $parse_head;
+ my $show_progress = delete $cnf{show_progress};
+ my $max_size = delete $cnf{max_size};
+ my $max_redirect = delete $cnf{max_redirect};
+ $max_redirect = 7 unless defined $max_redirect;
+ my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY};
+
+ my $cookie_jar = delete $cnf{cookie_jar};
+ my $conn_cache = delete $cnf{conn_cache};
+ my $keep_alive = delete $cnf{keep_alive};
+
+ Carp::croak("Can't mix conn_cache and keep_alive")
+ if $conn_cache && $keep_alive;
+
+ my $protocols_allowed = delete $cnf{protocols_allowed};
+ my $protocols_forbidden = delete $cnf{protocols_forbidden};
+
+ my $requests_redirectable = delete $cnf{requests_redirectable};
+ $requests_redirectable = ['GET', 'HEAD']
+ unless defined $requests_redirectable;
+
+ # Actually ""s are just as good as 0's, but for concision we'll just say:
+ Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
+ if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
+ Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
+ if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
+ Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
+ if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';
+
+
+ if (%cnf && $^W) {
+ Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
+ }
+
+ my $self = bless {
+ def_headers => $def_headers,
+ timeout => $timeout,
+ local_address => $local_address,
+ ssl_opts => $ssl_opts,
+ use_eval => $use_eval,
+ show_progress=> $show_progress,
+ max_size => $max_size,
+ max_redirect => $max_redirect,
+ proxy => {},
+ no_proxy => [],
+ protocols_allowed => $protocols_allowed,
+ protocols_forbidden => $protocols_forbidden,
+ requests_redirectable => $requests_redirectable,
+ }, $class;
+
+ $self->agent(defined($agent) ? $agent : $class->_agent)
+ if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
+ $self->from($from) if $from;
+ $self->cookie_jar($cookie_jar) if $cookie_jar;
+ $self->parse_head($parse_head);
+ $self->env_proxy if $env_proxy;
+
+ $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
+ $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
+
+ if ($keep_alive) {
+ $conn_cache ||= { total_capacity => $keep_alive };
+ }
+ $self->conn_cache($conn_cache) if $conn_cache;
+
+ return $self;
+}
+
+
+sub send_request
+{
+ my($self, $request, $arg, $size) = @_;
+ my($method, $url) = ($request->method, $request->uri);
+ my $scheme = $url->scheme;
+
+ local($SIG{__DIE__}); # protect against user defined die handlers
+
+ $self->progress("begin", $request);
+
+ my $response = $self->run_handlers("request_send", $request);
+
+ unless ($response) {
+ my $protocol;
+
+ {
+ # Honor object-specific restrictions by forcing protocol objects
+ # into class LWP::Protocol::nogo.
+ my $x;
+ if($x = $self->protocols_allowed) {
+ if (grep lc($_) eq $scheme, @$x) {
+ }
+ else {
+ require LWP::Protocol::nogo;
+ $protocol = LWP::Protocol::nogo->new;
+ }
+ }
+ elsif ($x = $self->protocols_forbidden) {
+ if(grep lc($_) eq $scheme, @$x) {
+ require LWP::Protocol::nogo;
+ $protocol = LWP::Protocol::nogo->new;
+ }
+ }
+ # else fall thru and create the protocol object normally
+ }
+
+ # Locate protocol to use
+ my $proxy = $request->{proxy};
+ if ($proxy) {
+ $scheme = $proxy->scheme;
+ }
+
+ unless ($protocol) {
+ $protocol = eval { LWP::Protocol::create($scheme, $self) };
+ if ($@) {
+ $@ =~ s/ at .* line \d+.*//s; # remove file/line number
+ $response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
+ if ($scheme eq "https") {
+ $response->message($response->message . " (LWP::Protocol::https not installed)");
+ $response->content_type("text/plain");
+ $response->content(<<EOT);
+LWP will support https URLs if the LWP::Protocol::https module
+is installed.
+EOT
+ }
+ }
+ }
+
+ if (!$response && $self->{use_eval}) {
+ # we eval, and turn dies into responses below
+ eval {
+ $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) ||
+ die "No response returned by $protocol";
+ };
+ if ($@) {
+ if (UNIVERSAL::isa($@, "HTTP::Response")) {
+ $response = $@;
+ $response->request($request);
+ }
+ else {
+ my $full = $@;
+ (my $status = $@) =~ s/\n.*//s;
+ $status =~ s/ at .* line \d+.*//s; # remove file/line number
+ my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : &HTTP::Status::RC_INTERNAL_SERVER_ERROR;
+ $response = _new_response($request, $code, $status, $full);
+ }
+ }
+ }
+ elsif (!$response) {
+ $response = $protocol->request($request, $proxy,
+ $arg, $size, $self->{timeout});
+ # XXX: Should we die unless $response->is_success ???
+ }
+ }
+
+ $response->request($request); # record request for reference
+ $response->header("Client-Date" => HTTP::Date::time2str(time));
+
+ $self->run_handlers("response_done", $response);
+
+ $self->progress("end", $response);
+ return $response;
+}
+
+
+sub prepare_request
+{
+ my($self, $request) = @_;
+ die "Method missing" unless $request->method;
+ my $url = $request->uri;
+ die "URL missing" unless $url;
+ die "URL must be absolute" unless $url->scheme;
+
+ $self->run_handlers("request_preprepare", $request);
+
+ if (my $def_headers = $self->{def_headers}) {
+ for my $h ($def_headers->header_field_names) {
+ $request->init_header($h => [$def_headers->header($h)]);
+ }
+ }
+
+ $self->run_handlers("request_prepare", $request);
+
+ return $request;
+}
+
+
+sub simple_request
+{
+ my($self, $request, $arg, $size) = @_;
+
+ # sanity check the request passed in
+ if (defined $request) {
+ if (ref $request) {
+ Carp::croak("You need a request object, not a " . ref($request) . " object")
+ if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
+ !$request->can('method') or !$request->can('uri');
+ }
+ else {
+ Carp::croak("You need a request object, not '$request'");
+ }
+ }
+ else {
+ Carp::croak("No request object passed in");
+ }
+
+ eval {
+ $request = $self->prepare_request($request);
+ };
+ if ($@) {
+ $@ =~ s/ at .* line \d+.*//s; # remove file/line number
+ return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
+ }
+ return $self->send_request($request, $arg, $size);
+}
+
+
+sub request
+{
+ my($self, $request, $arg, $size, $previous) = @_;
+
+ my $response = $self->simple_request($request, $arg, $size);
+ $response->previous($previous) if $previous;
+
+ if ($response->redirects >= $self->{max_redirect}) {
+ $response->header("Client-Warning" =>
+ "Redirect loop detected (max_redirect = $self->{max_redirect})");
+ return $response;
+ }
+
+ if (my $req = $self->run_handlers("response_redirect", $response)) {
+ return $self->request($req, $arg, $size, $response);
+ }
+
+ my $code = $response->code;
+
+ if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
+ $code == &HTTP::Status::RC_FOUND or
+ $code == &HTTP::Status::RC_SEE_OTHER or
+ $code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
+ {
+ my $referral = $request->clone;
+
+ # These headers should never be forwarded
+ $referral->remove_header('Host', 'Cookie');
+
+ if ($referral->header('Referer') &&
+ $request->uri->scheme eq 'https' &&
+ $referral->uri->scheme eq 'http')
+ {
+ # RFC 2616, section 15.1.3.
+ # https -> http redirect, suppressing Referer
+ $referral->remove_header('Referer');
+ }
+
+ if ($code == &HTTP::Status::RC_SEE_OTHER ||
+ $code == &HTTP::Status::RC_FOUND)
+ {
+ my $method = uc($referral->method);
+ unless ($method eq "GET" || $method eq "HEAD") {
+ $referral->method("GET");
+ $referral->content("");
+ $referral->remove_content_headers;
+ }
+ }
+
+ # And then we update the URL based on the Location:-header.
+ my $referral_uri = $response->header('Location');
+ {
+ # Some servers erroneously return a relative URL for redirects,
+ # so make it absolute if it not already is.
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+ my $base = $response->base;
+ $referral_uri = "" unless defined $referral_uri;
+ $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
+ ->abs($base);
+ }
+ $referral->uri($referral_uri);
+
+ return $response unless $self->redirect_ok($referral, $response);
+ return $self->request($referral, $arg, $size, $response);
+
+ }
+ elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
+ $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
+ )
+ {
+ my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
+ my $ch_header = $proxy ? "Proxy-Authenticate" : "WWW-Authenticate";
+ my @challenge = $response->header($ch_header);
+ unless (@challenge) {
+ $response->header("Client-Warning" =>
+ "Missing Authenticate header");
+ return $response;
+ }
+
+ require HTTP::Headers::Util;
+ CHALLENGE: for my $challenge (@challenge) {
+ $challenge =~ tr/,/;/; # "," is used to separate auth-params!!
+ ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
+ my $scheme = shift(@$challenge);
+ shift(@$challenge); # no value
+ $challenge = { @$challenge }; # make rest into a hash
+
+ unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
+ $response->header("Client-Warning" =>
+ "Bad authentication scheme '$scheme'");
+ return $response;
+ }
+ $scheme = $1; # untainted now
+ my $class = "LWP::Authen::\u$scheme";
+ $class =~ s/-/_/g;
+
+ no strict 'refs';
+ unless (%{"$class\::"}) {
+ # try to load it
+ eval "require $class";
+ if ($@) {
+ if ($@ =~ /^Can\'t locate/) {
+ $response->header("Client-Warning" =>
+ "Unsupported authentication scheme '$scheme'");
+ }
+ else {
+ $response->header("Client-Warning" => $@);
+ }
+ next CHALLENGE;
+ }
+ }
+ unless ($class->can("authenticate")) {
+ $response->header("Client-Warning" =>
+ "Unsupported authentication scheme '$scheme'");
+ next CHALLENGE;
+ }
+ return $class->authenticate($self, $proxy, $challenge, $response,
+ $request, $arg, $size);
+ }
+ return $response;
+ }
+ return $response;
+}
+
+
+#
+# Now the shortcuts...
+#
+sub get {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters,1);
+ return $self->request( HTTP::Request::Common::GET( @parameters ), @suff );
+}
+
+
+sub post {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
+ return $self->request( HTTP::Request::Common::POST( @parameters ), @suff );
+}
+
+
+sub head {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters,1);
+ return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff );
+}
+
+
+sub put {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
+ return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
+}
+
+
+sub delete {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters,1);
+ return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
+}
+
+
+sub _process_colonic_headers {
+ # Process :content_cb / :content_file / :read_size_hint headers.
+ my($self, $args, $start_index) = @_;
+
+ my($arg, $size);
+ for(my $i = $start_index; $i < @$args; $i += 2) {
+ next unless defined $args->[$i];
+
+ #printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];
+
+ if($args->[$i] eq ':content_cb') {
+ # Some sanity-checking...
+ $arg = $args->[$i + 1];
+ Carp::croak("A :content_cb value can't be undef") unless defined $arg;
+ Carp::croak("A :content_cb value must be a coderef")
+ unless ref $arg and UNIVERSAL::isa($arg, 'CODE');
+
+ }
+ elsif ($args->[$i] eq ':content_file') {
+ $arg = $args->[$i + 1];
+
+ # Some sanity-checking...
+ Carp::croak("A :content_file value can't be undef")
+ unless defined $arg;
+ Carp::croak("A :content_file value can't be a reference")
+ if ref $arg;
+ Carp::croak("A :content_file value can't be \"\"")
+ unless length $arg;
+
+ }
+ elsif ($args->[$i] eq ':read_size_hint') {
+ $size = $args->[$i + 1];
+ # Bother checking it?
+
+ }
+ else {
+ next;
+ }
+ splice @$args, $i, 2;
+ $i -= 2;
+ }
+
+ # And return a suitable suffix-list for request(REQ,...)
+
+ return unless defined $arg;
+ return $arg, $size if defined $size;
+ return $arg;
+}
+
+
+sub is_online {
+ my $self = shift;
+ return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI";
+ return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,;
+ return 0;
+}
+
+
+my @ANI = qw(- \ | /);
+
+sub progress {
+ my($self, $status, $m) = @_;
+ return unless $self->{show_progress};
+
+ local($,, $\);
+ if ($status eq "begin") {
+ print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
+ $self->{progress_start} = time;
+ $self->{progress_lastp} = "";
+ $self->{progress_ani} = 0;
+ }
+ elsif ($status eq "end") {
+ delete $self->{progress_lastp};
+ delete $self->{progress_ani};
+ print STDERR $m->status_line;
+ my $t = time - delete $self->{progress_start};
+ print STDERR " (${t}s)" if $t;
+ print STDERR "\n";
+ }
+ elsif ($status eq "tick") {
+ print STDERR "$ANI[$self->{progress_ani}++]\b";
+ $self->{progress_ani} %= @ANI;
+ }
+ else {
+ my $p = sprintf "%3.0f%%", $status * 100;
+ return if $p eq $self->{progress_lastp};
+ print STDERR "$p\b\b\b\b";
+ $self->{progress_lastp} = $p;
+ }
+ STDERR->flush;
+}
+
+
+#
+# This whole allow/forbid thing is based on man 1 at's way of doing things.
+#
+sub is_protocol_supported
+{
+ my($self, $scheme) = @_;
+ if (ref $scheme) {
+ # assume we got a reference to an URI object
+ $scheme = $scheme->scheme;
+ }
+ else {
+ Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
+ if $scheme =~ /\W/;
+ $scheme = lc $scheme;
+ }
+
+ my $x;
+ if(ref($self) and $x = $self->protocols_allowed) {
+ return 0 unless grep lc($_) eq $scheme, @$x;
+ }
+ elsif (ref($self) and $x = $self->protocols_forbidden) {
+ return 0 if grep lc($_) eq $scheme, @$x;
+ }
+
+ local($SIG{__DIE__}); # protect against user defined die handlers
+ $x = LWP::Protocol::implementor($scheme);
+ return 1 if $x and $x ne 'LWP::Protocol::nogo';
+ return 0;
+}
+
+
+sub protocols_allowed { shift->_elem('protocols_allowed' , @_) }
+sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) }
+sub requests_redirectable { shift->_elem('requests_redirectable', @_) }
+
+
+sub redirect_ok
+{
+ # RFC 2616, section 10.3.2 and 10.3.3 say:
+ # If the 30[12] status code is received in response to a request other
+ # than GET or HEAD, the user agent MUST NOT automatically redirect the
+ # request unless it can be confirmed by the user, since this might
+ # change the conditions under which the request was issued.
+
+ # Note that this routine used to be just:
+ # return 0 if $_[1]->method eq "POST"; return 1;
+
+ my($self, $new_request, $response) = @_;
+ my $method = $response->request->method;
+ return 0 unless grep $_ eq $method,
+ @{ $self->requests_redirectable || [] };
+
+ if ($new_request->uri->scheme eq 'file') {
+ $response->header("Client-Warning" =>
+ "Can't redirect to a file:// URL!");
+ return 0;
+ }
+
+ # Otherwise it's apparently okay...
+ return 1;
+}
+
+
+sub credentials
+{
+ my $self = shift;
+ my $netloc = lc(shift);
+ my $realm = shift || "";
+ my $old = $self->{basic_authentication}{$netloc}{$realm};
+ if (@_) {
+ $self->{basic_authentication}{$netloc}{$realm} = [@_];
+ }
+ return unless $old;
+ return @$old if wantarray;
+ return join(":", @$old);
+}
+
+
+sub get_basic_credentials
+{
+ my($self, $realm, $uri, $proxy) = @_;
+ return if $proxy;
+ return $self->credentials($uri->host_port, $realm);
+}
+
+
+sub timeout { shift->_elem('timeout', @_); }
+sub local_address{ shift->_elem('local_address',@_); }
+sub max_size { shift->_elem('max_size', @_); }
+sub max_redirect { shift->_elem('max_redirect', @_); }
+sub show_progress{ shift->_elem('show_progress', @_); }
+
+sub ssl_opts {
+ my $self = shift;
+ if (@_ == 1) {
+ my $k = shift;
+ return $self->{ssl_opts}{$k};
+ }
+ if (@_) {
+ my $old;
+ while (@_) {
+ my($k, $v) = splice(@_, 0, 2);
+ $old = $self->{ssl_opts}{$k} unless @_;
+ if (defined $v) {
+ $self->{ssl_opts}{$k} = $v;
+ }
+ else {
+ delete $self->{ssl_opts}{$k};
+ }
+ }
+ %{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_);
+ return $old;
+ }
+
+ return keys %{$self->{ssl_opts}};
+}
+
+sub parse_head {
+ my $self = shift;
+ if (@_) {
+ my $flag = shift;
+ my $parser;
+ my $old = $self->set_my_handler("response_header", $flag ? sub {
+ my($response, $ua) = @_;
+ require HTML::HeadParser;
+ $parser = HTML::HeadParser->new;
+ $parser->xml_mode(1) if $response->content_is_xhtml;
+ $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
+
+ push(@{$response->{handlers}{response_data}}, {
+ callback => sub {
+ return unless $parser;
+ unless ($parser->parse($_[3])) {
+ my $h = $parser->header;
+ my $r = $_[0];
+ for my $f ($h->header_field_names) {
+ $r->init_header($f, [$h->header($f)]);
+ }
+ undef($parser);
+ }
+ },
+ });
+
+ } : undef,
+ m_media_type => "html",
+ );
+ return !!$old;
+ }
+ else {
+ return !!$self->get_my_handler("response_header");
+ }
+}
+
+sub cookie_jar {
+ my $self = shift;
+ my $old = $self->{cookie_jar};
+ if (@_) {
+ my $jar = shift;
+ if (ref($jar) eq "HASH") {
+ require HTTP::Cookies;
+ $jar = HTTP::Cookies->new(%$jar);
+ }
+ $self->{cookie_jar} = $jar;
+ $self->set_my_handler("request_prepare",
+ $jar ? sub { $jar->add_cookie_header($_[0]); } : undef,
+ );
+ $self->set_my_handler("response_done",
+ $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
+ );
+ }
+ $old;
+}
+
+sub default_headers {
+ my $self = shift;
+ my $old = $self->{def_headers} ||= HTTP::Headers->new;
+ if (@_) {
+ Carp::croak("default_headers not set to HTTP::Headers compatible object")
+ unless @_ == 1 && $_[0]->can("header_field_names");
+ $self->{def_headers} = shift;
+ }
+ return $old;
+}
+
+sub default_header {
+ my $self = shift;
+ return $self->default_headers->header(@_);
+}
+
+sub _agent { "libwww-perl/$LWP::VERSION" }
+
+sub agent {
+ my $self = shift;
+ if (@_) {
+ my $agent = shift;
+ if ($agent) {
+ $agent .= $self->_agent if $agent =~ /\s+$/;
+ }
+ else {
+ undef($agent)
+ }
+ return $self->default_header("User-Agent", $agent);
+ }
+ return $self->default_header("User-Agent");
+}
+
+sub from { # legacy
+ my $self = shift;
+ return $self->default_header("From", @_);
+}
+
+
+sub conn_cache {
+ my $self = shift;
+ my $old = $self->{conn_cache};
+ if (@_) {
+ my $cache = shift;
+ if (ref($cache) eq "HASH") {
+ require LWP::ConnCache;
+ $cache = LWP::ConnCache->new(%$cache);
+ }
+ $self->{conn_cache} = $cache;
+ }
+ $old;
+}
+
+
+sub add_handler {
+ my($self, $phase, $cb, %spec) = @_;
+ $spec{line} ||= join(":", (caller)[1,2]);
+ my $conf = $self->{handlers}{$phase} ||= do {
+ require HTTP::Config;
+ HTTP::Config->new;
+ };
+ $conf->add(%spec, callback => $cb);
+}
+
+sub set_my_handler {
+ my($self, $phase, $cb, %spec) = @_;
+ $spec{owner} = (caller(1))[3] unless exists $spec{owner};
+ $self->remove_handler($phase, %spec);
+ $spec{line} ||= join(":", (caller)[1,2]);
+ $self->add_handler($phase, $cb, %spec) if $cb;
+}
+
+sub get_my_handler {
+ my $self = shift;
+ my $phase = shift;
+ my $init = pop if @_ % 2;
+ my %spec = @_;
+ my $conf = $self->{handlers}{$phase};
+ unless ($conf) {
+ return unless $init;
+ require HTTP::Config;
+ $conf = $self->{handlers}{$phase} = HTTP::Config->new;
+ }
+ $spec{owner} = (caller(1))[3] unless exists $spec{owner};
+ my @h = $conf->find(%spec);
+ if (!@h && $init) {
+ if (ref($init) eq "CODE") {
+ $init->(\%spec);
+ }
+ elsif (ref($init) eq "HASH") {
+ while (my($k, $v) = each %$init) {
+ $spec{$k} = $v;
+ }
+ }
+ $spec{callback} ||= sub {};
+ $spec{line} ||= join(":", (caller)[1,2]);
+ $conf->add(\%spec);
+ return \%spec;
+ }
+ return wantarray ? @h : $h[0];
+}
+
+sub remove_handler {
+ my($self, $phase, %spec) = @_;
+ if ($phase) {
+ my $conf = $self->{handlers}{$phase} || return;
+ my @h = $conf->remove(%spec);
+ delete $self->{handlers}{$phase} if $conf->empty;
+ return @h;
+ }
+
+ return unless $self->{handlers};
+ return map $self->remove_handler($_), sort keys %{$self->{handlers}};
+}
+
+sub handlers {
+ my($self, $phase, $o) = @_;
+ my @h;
+ if ($o->{handlers} && $o->{handlers}{$phase}) {
+ push(@h, @{$o->{handlers}{$phase}});
+ }
+ if (my $conf = $self->{handlers}{$phase}) {
+ push(@h, $conf->matching($o));
+ }
+ return @h;
+}
+
+sub run_handlers {
+ my($self, $phase, $o) = @_;
+ if (defined(wantarray)) {
+ for my $h ($self->handlers($phase, $o)) {
+ my $ret = $h->{callback}->($o, $self, $h);
+ return $ret if $ret;
+ }
+ return undef;
+ }
+
+ for my $h ($self->handlers($phase, $o)) {
+ $h->{callback}->($o, $self, $h);
+ }
+}
+
+
+# depreciated
+sub use_eval { shift->_elem('use_eval', @_); }
+sub use_alarm
+{
+ Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
+ if @_ > 1 && $^W;
+ "";
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $copy = bless { %$self }, ref $self; # copy most fields
+
+ delete $copy->{handlers};
+ delete $copy->{conn_cache};
+
+ # copy any plain arrays and hashes; known not to need recursive copy
+ for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) {
+ next unless $copy->{$k};
+ if (ref($copy->{$k}) eq "ARRAY") {
+ $copy->{$k} = [ @{$copy->{$k}} ];
+ }
+ elsif (ref($copy->{$k}) eq "HASH") {
+ $copy->{$k} = { %{$copy->{$k}} };
+ }
+ }
+
+ if ($self->{def_headers}) {
+ $copy->{def_headers} = $self->{def_headers}->clone;
+ }
+
+ # re-enable standard handlers
+ $copy->parse_head($self->parse_head);
+
+ # no easy way to clone the cookie jar; so let's just remove it for now
+ $copy->cookie_jar(undef);
+
+ $copy;
+}
+
+
+sub mirror
+{
+ my($self, $url, $file) = @_;
+
+ my $request = HTTP::Request->new('GET', $url);
+
+ # If the file exists, add a cache-related header
+ if ( -e $file ) {
+ my ($mtime) = ( stat($file) )[9];
+ if ($mtime) {
+ $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
+ }
+ }
+ my $tmpfile = "$file-$$";
+
+ my $response = $self->request($request, $tmpfile);
+ if ( $response->header('X-Died') ) {
+ die $response->header('X-Died');
+ }
+
+ # Only fetching a fresh copy of the would be considered success.
+ # If the file was not modified, "304" would returned, which
+ # is considered by HTTP::Status to be a "redirect", /not/ "success"
+ if ( $response->is_success ) {
+ my @stat = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!";
+ my $file_length = $stat[7];
+ my ($content_length) = $response->header('Content-length');
+
+ if ( defined $content_length and $file_length < $content_length ) {
+ unlink($tmpfile);
+ die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
+ }
+ elsif ( defined $content_length and $file_length > $content_length ) {
+ unlink($tmpfile);
+ die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
+ }
+ # The file was the expected length.
+ else {
+ # Replace the stale file with a fresh copy
+ if ( -e $file ) {
+ # Some dosish systems fail to rename if the target exists
+ chmod 0777, $file;
+ unlink $file;
+ }
+ rename( $tmpfile, $file )
+ or die "Cannot rename '$tmpfile' to '$file': $!\n";
+
+ # make sure the file has the same last modification time
+ if ( my $lm = $response->last_modified ) {
+ utime $lm, $lm, $file;
+ }
+ }
+ }
+ # The local copy is fresh enough, so just delete the temp file
+ else {
+ unlink($tmpfile);
+ }
+ return $response;
+}
+
+
+sub _need_proxy {
+ my($req, $ua) = @_;
+ return if exists $req->{proxy};
+ my $proxy = $ua->{proxy}{$req->uri->scheme} || return;
+ if ($ua->{no_proxy}) {
+ if (my $host = eval { $req->uri->host }) {
+ for my $domain (@{$ua->{no_proxy}}) {
+ if ($host =~ /\Q$domain\E$/) {
+ return;
+ }
+ }
+ }
+ }
+ $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
+}
+
+
+sub proxy
+{
+ my $self = shift;
+ my $key = shift;
+ return map $self->proxy($_, @_), @$key if ref $key;
+
+ Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
+ my $old = $self->{'proxy'}{$key};
+ if (@_) {
+ my $url = shift;
+ if (defined($url) && length($url)) {
+ Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/;
+ Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://\w,;
+ }
+ $self->{proxy}{$key} = $url;
+ $self->set_my_handler("request_preprepare", \&_need_proxy)
+ }
+ return $old;
+}
+
+
+sub env_proxy {
+ my ($self) = @_;
+ require Encode;
+ require Encode::Locale;
+ my($k,$v);
+ while(($k, $v) = each %ENV) {
+ if ($ENV{REQUEST_METHOD}) {
+ # Need to be careful when called in the CGI environment, as
+ # the HTTP_PROXY variable is under control of that other guy.
+ next if $k =~ /^HTTP_/;
+ $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
+ }
+ $k = lc($k);
+ next unless $k =~ /^(.*)_proxy$/;
+ $k = $1;
+ if ($k eq 'no') {
+ $self->no_proxy(split(/\s*,\s*/, $v));
+ }
+ else {
+ # Ignore random _proxy variables, allow only valid schemes
+ next unless $k =~ /^$URI::scheme_re\z/;
+ # Ignore xxx_proxy variables if xxx isn't a supported protocol
+ next unless LWP::Protocol::implementor($k);
+ $self->proxy($k, Encode::decode(locale => $v));
+ }
+ }
+}
+
+
+sub no_proxy {
+ my($self, @no) = @_;
+ if (@no) {
+ push(@{ $self->{'no_proxy'} }, @no);
+ }
+ else {
+ $self->{'no_proxy'} = [];
+ }
+}
+
+
+sub _new_response {
+ my($request, $code, $message, $content) = @_;
+ my $response = HTTP::Response->new($code, $message);
+ $response->request($request);
+ $response->header("Client-Date" => HTTP::Date::time2str(time));
+ $response->header("Client-Warning" => "Internal response");
+ $response->header("Content-Type" => "text/plain");
+ $response->content($content || "$code $message\n");
+ return $response;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+LWP::UserAgent - Web user agent class
+
+=head1 SYNOPSIS
+
+ require LWP::UserAgent;
+
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(10);
+ $ua->env_proxy;
+
+ my $response = $ua->get('http://search.cpan.org/');
+
+ if ($response->is_success) {
+ print $response->decoded_content; # or whatever
+ }
+ else {
+ die $response->status_line;
+ }
+
+=head1 DESCRIPTION
+
+The C<LWP::UserAgent> is a class implementing a web user agent.
+C<LWP::UserAgent> objects can be used to dispatch web requests.
+
+In normal use the application creates an C<LWP::UserAgent> object, and
+then configures it with values for timeouts, proxies, name, etc. It
+then creates an instance of C<HTTP::Request> for the request that
+needs to be performed. This request is then passed to one of the
+request method the UserAgent, which dispatches it using the relevant
+protocol, and returns a C<HTTP::Response> object. There are
+convenience methods for sending the most common request types: get(),
+head(), post(), put() and delete(). When using these methods then the
+creation of the request object is hidden as shown in the synopsis above.
+
+The basic approach of the library is to use HTTP style communication
+for all protocol schemes. This means that you will construct
+C<HTTP::Request> objects and receive C<HTTP::Response> objects even
+for non-HTTP resources like I<gopher> and I<ftp>. In order to achieve
+even more similarity to HTTP style communications, gopher menus and
+file directories are converted to HTML documents.
+
+=head1 CONSTRUCTOR METHODS
+
+The following constructor methods are available:
+
+=over 4
+
+=item $ua = LWP::UserAgent->new( %options )
+
+This method constructs a new C<LWP::UserAgent> object and returns it.
+Key/value pair arguments may be provided to set up the initial state.
+The following options correspond to attribute methods described below:
+
+ KEY DEFAULT
+ ----------- --------------------
+ agent "libwww-perl/#.###"
+ from undef
+ conn_cache undef
+ cookie_jar undef
+ default_headers HTTP::Headers->new
+ local_address undef
+ ssl_opts { verify_hostname => 1 }
+ max_size undef
+ max_redirect 7
+ parse_head 1
+ protocols_allowed undef
+ protocols_forbidden undef
+ requests_redirectable ['GET', 'HEAD']
+ timeout 180
+
+The following additional options are also accepted: If the C<env_proxy> option
+is passed in with a TRUE value, then proxy settings are read from environment
+variables (see env_proxy() method below). If C<env_proxy> isn't provided the
+C<PERL_LWP_ENV_PROXY> environment variable controls if env_proxy() is called
+during initalization. If the C<keep_alive> option is passed in, then a
+C<LWP::ConnCache> is set up (see conn_cache() method below). The C<keep_alive>
+value is passed on as the C<total_capacity> for the connection cache.
+
+=item $ua->clone
+
+Returns a copy of the LWP::UserAgent object.
+
+=back
+
+=head1 ATTRIBUTES
+
+The settings of the configuration attributes modify the behaviour of the
+C<LWP::UserAgent> when it dispatches requests. Most of these can also
+be initialized by options passed to the constructor method.
+
+The following attribute methods are provided. The attribute value is
+left unchanged if no argument is given. The return value from each
+method is the old attribute value.
+
+=over
+
+=item $ua->agent
+
+=item $ua->agent( $product_id )
+
+Get/set the product token that is used to identify the user agent on
+the network. The agent value is sent as the "User-Agent" header in
+the requests. The default is the string returned by the _agent()
+method (see below).
+
+If the $product_id ends with space then the _agent() string is
+appended to it.
+
+The user agent string should be one or more simple product identifiers
+with an optional version number separated by the "/" character.
+Examples are:
+
+ $ua->agent('Checkbot/0.4 ' . $ua->_agent);
+ $ua->agent('Checkbot/0.4 '); # same as above
+ $ua->agent('Mozilla/5.0');
+ $ua->agent(""); # don't identify
+
+=item $ua->_agent
+
+Returns the default agent identifier. This is a string of the form
+"libwww-perl/#.###", where "#.###" is substituted with the version number
+of this library.
+
+=item $ua->from
+
+=item $ua->from( $email_address )
+
+Get/set the e-mail address for the human user who controls
+the requesting user agent. The address should be machine-usable, as
+defined in RFC 822. The C<from> value is send as the "From" header in
+the requests. Example:
+
+ $ua->from('gaas@cpan.org');
+
+The default is to not send a "From" header. See the default_headers()
+method for the more general interface that allow any header to be defaulted.
+
+=item $ua->cookie_jar
+
+=item $ua->cookie_jar( $cookie_jar_obj )
+
+Get/set the cookie jar object to use. The only requirement is that
+the cookie jar object must implement the extract_cookies($request) and
+add_cookie_header($response) methods. These methods will then be
+invoked by the user agent as requests are sent and responses are
+received. Normally this will be a C<HTTP::Cookies> object or some
+subclass.
+
+The default is to have no cookie_jar, i.e. never automatically add
+"Cookie" headers to the requests.
+
+Shortcut: If a reference to a plain hash is passed in as the
+$cookie_jar_object, then it is replaced with an instance of
+C<HTTP::Cookies> that is initialized based on the hash. This form also
+automatically loads the C<HTTP::Cookies> module. It means that:
+
+ $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });
+
+is really just a shortcut for:
+
+ require HTTP::Cookies;
+ $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));
+
+=item $ua->default_headers
+
+=item $ua->default_headers( $headers_obj )
+
+Get/set the headers object that will provide default header values for
+any requests sent. By default this will be an empty C<HTTP::Headers>
+object.
+
+=item $ua->default_header( $field )
+
+=item $ua->default_header( $field => $value )
+
+This is just a short-cut for $ua->default_headers->header( $field =>
+$value ). Example:
+
+ $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
+ $ua->default_header('Accept-Language' => "no, en");
+
+=item $ua->conn_cache
+
+=item $ua->conn_cache( $cache_obj )
+
+Get/set the C<LWP::ConnCache> object to use. See L<LWP::ConnCache>
+for details.
+
+=item $ua->credentials( $netloc, $realm )
+
+=item $ua->credentials( $netloc, $realm, $uname, $pass )
+
+Get/set the user name and password to be used for a realm.
+
+The $netloc is a string of the form "<host>:<port>". The username and
+password will only be passed to this server. Example:
+
+ $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
+
+=item $ua->local_address
+
+=item $ua->local_address( $address )
+
+Get/set the local interface to bind to for network connections. The interface
+can be specified as a hostname or an IP address. This value is passed as the
+C<LocalAddr> argument to L<IO::Socket::INET>.
+
+=item $ua->max_size
+
+=item $ua->max_size( $bytes )
+
+Get/set the size limit for response content. The default is C<undef>,
+which means that there is no limit. If the returned response content
+is only partial, because the size limit was exceeded, then a
+"Client-Aborted" header will be added to the response. The content
+might end up longer than C<max_size> as we abort once appending a
+chunk of data makes the length exceed the limit. The "Content-Length"
+header, if present, will indicate the length of the full content and
+will normally not be the same as C<< length($res->content) >>.
+
+=item $ua->max_redirect
+
+=item $ua->max_redirect( $n )
+
+This reads or sets the object's limit of how many times it will obey
+redirection responses in a given request cycle.
+
+By default, the value is 7. This means that if you call request()
+method and the response is a redirect elsewhere which is in turn a
+redirect, and so on seven times, then LWP gives up after that seventh
+request.
+
+=item $ua->parse_head
+
+=item $ua->parse_head( $boolean )
+
+Get/set a value indicating whether we should initialize response
+headers from the E<lt>head> section of HTML documents. The default is
+TRUE. Do not turn this off, unless you know what you are doing.
+
+=item $ua->protocols_allowed
+
+=item $ua->protocols_allowed( \@protocols )
+
+This reads (or sets) this user agent's list of protocols that the
+request methods will exclusively allow. The protocol names are case
+insensitive.
+
+For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
+means that this user agent will I<allow only> those protocols,
+and attempts to use this user agent to access URLs with any other
+schemes (like "ftp://...") will result in a 500 error.
+
+To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)>
+
+By default, an object has neither a C<protocols_allowed> list, nor a
+C<protocols_forbidden> list.
+
+Note that having a C<protocols_allowed> list causes any
+C<protocols_forbidden> list to be ignored.
+
+=item $ua->protocols_forbidden
+
+=item $ua->protocols_forbidden( \@protocols )
+
+This reads (or sets) this user agent's list of protocols that the
+request method will I<not> allow. The protocol names are case
+insensitive.
+
+For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
+means that this user agent will I<not> allow those protocols, and
+attempts to use this user agent to access URLs with those schemes
+will result in a 500 error.
+
+To delete the list, call: C<$ua-E<gt>protocols_forbidden(undef)>
+
+=item $ua->requests_redirectable
+
+=item $ua->requests_redirectable( \@requests )
+
+This reads or sets the object's list of request names that
+C<$ua-E<gt>redirect_ok(...)> will allow redirection for. By
+default, this is C<['GET', 'HEAD']>, as per RFC 2616. To
+change to include 'POST', consider:
+
+ push @{ $ua->requests_redirectable }, 'POST';
+
+=item $ua->show_progress
+
+=item $ua->show_progress( $boolean )
+
+Get/set a value indicating whether a progress bar should be displayed
+on on the terminal as requests are processed. The default is FALSE.
+
+=item $ua->timeout
+
+=item $ua->timeout( $secs )
+
+Get/set the timeout value in seconds. The default timeout() value is
+180 seconds, i.e. 3 minutes.
+
+The requests is aborted if no activity on the connection to the server
+is observed for C<timeout> seconds. This means that the time it takes
+for the complete transaction and the request() method to actually
+return might be longer.
+
+=item $ua->ssl_opts
+
+=item $ua->ssl_opts( $key )
+
+=item $ua->ssl_opts( $key => $value )
+
+Get/set the options for SSL connections. Without argument return the list
+of options keys currently set. With a single argument return the current
+value for the given option. With 2 arguments set the option value and return
+the old. Setting an option to the value C<undef> removes this option.
+
+The options that LWP relates to are:
+
+=over
+
+=item C<verify_hostname> => $bool
+
+When TRUE LWP will for secure protocol schemes ensure it connects to servers
+that have a valid certificate matching the expected hostname. If FALSE no
+checks are made and you can't be sure that you communicate with the expected peer.
+The no checks behaviour was the default for libwww-perl-5.837 and earlier releases.
+
+This option is initialized from the L<PERL_LWP_SSL_VERIFY_HOSTNAME> environment
+variable. If this environment variable isn't set; then C<verify_hostname>
+defaults to 1.
+
+=item C<SSL_ca_file> => $path
+
+The path to a file containing Certificate Authority certificates.
+A default setting for this option is provided by checking the environment
+variables C<PERL_LWP_SSL_CA_FILE> and C<HTTPS_CA_FILE> in order.
+
+=item C<SSL_ca_path> => $path
+
+The path to a directory containing files containing Certificate Authority
+certificates.
+A default setting for this option is provided by checking the environment
+variables C<PERL_LWP_SSL_CA_PATH> and C<HTTPS_CA_DIR> in order.
+
+=back
+
+Other options can be set and are processed directly by the SSL Socket implementation
+in use. See L<IO::Socket::SSL> or L<Net::SSL> for details.
+
+The libwww-perl core no longer bundles protocol plugins for SSL. You will need
+to install L<LWP::Protocol::https> separately to enable support for processing
+https-URLs.
+
+=back
+
+=head2 Proxy attributes
+
+The following methods set up when requests should be passed via a
+proxy server.
+
+=over
+
+=item $ua->proxy(\@schemes, $proxy_url)
+
+=item $ua->proxy($scheme, $proxy_url)
+
+Set/retrieve proxy URL for a scheme:
+
+ $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
+ $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
+
+The first form specifies that the URL is to be used for proxying of
+access methods listed in the list in the first method argument,
+i.e. 'http' and 'ftp'.
+
+The second form shows a shorthand form for specifying
+proxy URL for a single access scheme.
+
+=item $ua->no_proxy( $domain, ... )
+
+Do not proxy requests to the given domains. Calling no_proxy without
+any domains clears the list of domains. Eg:
+
+ $ua->no_proxy('localhost', 'example.com');
+
+=item $ua->env_proxy
+
+Load proxy settings from *_proxy environment variables. You might
+specify proxies like this (sh-syntax):
+
+ gopher_proxy=http://proxy.my.place/
+ wais_proxy=http://proxy.my.place/
+ no_proxy="localhost,example.com"
+ export gopher_proxy wais_proxy no_proxy
+
+csh or tcsh users should use the C<setenv> command to define these
+environment variables.
+
+On systems with case insensitive environment variables there exists a
+name clash between the CGI environment variables and the C<HTTP_PROXY>
+environment variable normally picked up by env_proxy(). Because of
+this C<HTTP_PROXY> is not honored for CGI scripts. The
+C<CGI_HTTP_PROXY> environment variable can be used instead.
+
+=back
+
+=head2 Handlers
+
+Handlers are code that injected at various phases during the
+processing of requests. The following methods are provided to manage
+the active handlers:
+
+=over
+
+=item $ua->add_handler( $phase => \&cb, %matchspec )
+
+Add handler to be invoked in the given processing phase. For how to
+specify %matchspec see L<HTTP::Config/"Matching">.
+
+The possible values $phase and the corresponding callback signatures are:
+
+=over
+
+=item request_preprepare => sub { my($request, $ua, $h) = @_; ... }
+
+The handler is called before the C<request_prepare> and other standard
+initialization of of the request. This can be used to set up headers
+and attributes that the C<request_prepare> handler depends on. Proxy
+initialization should take place here; but in general don't register
+handlers for this phase.
+
+=item request_prepare => sub { my($request, $ua, $h) = @_; ... }
+
+The handler is called before the request is sent and can modify the
+request any way it see fit. This can for instance be used to add
+certain headers to specific requests.
+
+The method can assign a new request object to $_[0] to replace the
+request that is sent fully.
+
+The return value from the callback is ignored. If an exception is
+raised it will abort the request and make the request method return a
+"400 Bad request" response.
+
+=item request_send => sub { my($request, $ua, $h) = @_; ... }
+
+This handler gets a chance of handling requests before they're sent to the
+protocol handlers. It should return an HTTP::Response object if it
+wishes to terminate the processing; otherwise it should return nothing.
+
+The C<response_header> and C<response_data> handlers will not be
+invoked for this response, but the C<response_done> will be.
+
+=item response_header => sub { my($response, $ua, $h) = @_; ... }
+
+This handler is called right after the response headers have been
+received, but before any content data. The handler might set up
+handlers for data and might croak to abort the request.
+
+The handler might set the $response->{default_add_content} value to
+control if any received data should be added to the response object
+directly. This will initially be false if the $ua->request() method
+was called with a $content_file or $content_cb argument; otherwise true.
+
+=item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
+
+This handler is called for each chunk of data received for the
+response. The handler might croak to abort the request.
+
+This handler needs to return a TRUE value to be called again for
+subsequent chunks for the same request.
+
+=item response_done => sub { my($response, $ua, $h) = @_; ... }
+
+The handler is called after the response has been fully received, but
+before any redirect handling is attempted. The handler can be used to
+extract information or modify the response.
+
+=item response_redirect => sub { my($response, $ua, $h) = @_; ... }
+
+The handler is called in $ua->request after C<response_done>. If the
+handler returns an HTTP::Request object we'll start over with processing
+this request instead.
+
+=back
+
+=item $ua->remove_handler( undef, %matchspec )
+
+=item $ua->remove_handler( $phase, %matchspec )
+
+Remove handlers that match the given %matchspec. If $phase is not
+provided remove handlers from all phases.
+
+Be careful as calling this function with %matchspec that is not not
+specific enough can remove handlers not owned by you. It's probably
+better to use the set_my_handler() method instead.
+
+The removed handlers are returned.
+
+=item $ua->set_my_handler( $phase, $cb, %matchspec )
+
+Set handlers private to the executing subroutine. Works by defaulting
+an C<owner> field to the %matchspec that holds the name of the called
+subroutine. You might pass an explicit C<owner> to override this.
+
+If $cb is passed as C<undef>, remove the handler.
+
+=item $ua->get_my_handler( $phase, %matchspec )
+
+=item $ua->get_my_handler( $phase, %matchspec, $init )
+
+Will retrieve the matching handler as hash ref.
+
+If C<$init> is passed passed as a TRUE value, create and add the
+handler if it's not found. If $init is a subroutine reference, then
+it's called with the created handler hash as argument. This sub might
+populate the hash with extra fields; especially the callback. If
+$init is a hash reference, merge the hashes.
+
+=item $ua->handlers( $phase, $request )
+
+=item $ua->handlers( $phase, $response )
+
+Returns the handlers that apply to the given request or response at
+the given processing phase.
+
+=back
+
+=head1 REQUEST METHODS
+
+The methods described in this section are used to dispatch requests
+via the user agent. The following request methods are provided:
+
+=over
+
+=item $ua->get( $url )
+
+=item $ua->get( $url , $field_name => $value, ... )
+
+This method will dispatch a C<GET> request on the given $url. Further
+arguments can be given to initialize the headers of the request. These
+are given as separate name/value pairs. The return value is a
+response object. See L<HTTP::Response> for a description of the
+interface it provides.
+
+There will still be a response object returned when LWP can't connect to the
+server specified in the URL or when other failures in protocol handlers occur.
+These internal responses use the standard HTTP status codes, so the responses
+can't be differentiated by testing the response status code alone. Error
+responses that LWP generates internally will have the "Client-Warning" header
+set to the value "Internal response". If you need to differentiate these
+internal responses from responses that a remote server actually generates, you
+need to test this header value.
+
+Fields names that start with ":" are special. These will not
+initialize headers of the request but will determine how the response
+content is treated. The following special field names are recognized:
+
+ :content_file => $filename
+ :content_cb => \&callback
+ :read_size_hint => $bytes
+
+If a $filename is provided with the C<:content_file> option, then the
+response content will be saved here instead of in the response
+object. If a callback is provided with the C<:content_cb> option then
+this function will be called for each chunk of the response content as
+it is received from the server. If neither of these options are
+given, then the response content will accumulate in the response
+object itself. This might not be suitable for very large response
+bodies. Only one of C<:content_file> or C<:content_cb> can be
+specified. The content of unsuccessful responses will always
+accumulate in the response object itself, regardless of the
+C<:content_file> or C<:content_cb> options passed in.
+
+The C<:read_size_hint> option is passed to the protocol module which
+will try to read data from the server in chunks of this size. A
+smaller value for the C<:read_size_hint> will result in a higher
+number of callback invocations.
+
+The callback function is called with 3 arguments: a chunk of data, a
+reference to the response object, and a reference to the protocol
+object. The callback can abort the request by invoking die(). The
+exception message will show up as the "X-Died" header field in the
+response returned by the get() function.
+
+=item $ua->head( $url )
+
+=item $ua->head( $url , $field_name => $value, ... )
+
+This method will dispatch a C<HEAD> request on the given $url.
+Otherwise it works like the get() method described above.
+
+=item $ua->post( $url, \%form )
+
+=item $ua->post( $url, \@form )
+
+=item $ua->post( $url, \%form, $field_name => $value, ... )
+
+=item $ua->post( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->post( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->post( $url, $field_name => $value,... Content => $content )
+
+This method will dispatch a C<POST> request on the given $url, with
+%form or @form providing the key/value pairs for the fill-in form
+content. Additional headers and content options are the same as for
+the get() method.
+
+This method will use the POST() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->put( $url, \%form )
+
+=item $ua->put( $url, \@form )
+
+=item $ua->put( $url, \%form, $field_name => $value, ... )
+
+=item $ua->put( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->put( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->put( $url, $field_name => $value,... Content => $content )
+
+This method will dispatch a C<PUT> request on the given $url, with
+%form or @form providing the key/value pairs for the fill-in form
+content. Additional headers and content options are the same as for
+the get() method.
+
+This method will use the PUT() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->delete( $url )
+
+=item $ua->delete( $url, $field_name => $value, ... )
+
+This method will dispatch a C<DELETE> request on the given $url. Additional
+headers and content options are the same as for the get() method.
+
+This method will use the DELETE() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->mirror( $url, $filename )
+
+This method will get the document identified by $url and store it in
+file called $filename. If the file already exists, then the request
+will contain an "If-Modified-Since" header matching the modification
+time of the file. If the document on the server has not changed since
+this time, then nothing happens. If the document has been updated, it
+will be downloaded again. The modification time of the file will be
+forced to match that of the server.
+
+The return value is the the response object.
+
+=item $ua->request( $request )
+
+=item $ua->request( $request, $content_file )
+
+=item $ua->request( $request, $content_cb )
+
+=item $ua->request( $request, $content_cb, $read_size_hint )
+
+This method will dispatch the given $request object. Normally this
+will be an instance of the C<HTTP::Request> class, but any object with
+a similar interface will do. The return value is a response object.
+See L<HTTP::Request> and L<HTTP::Response> for a description of the
+interface provided by these classes.
+
+The request() method will process redirects and authentication
+responses transparently. This means that it may actually send several
+simple requests via the simple_request() method described below.
+
+The request methods described above; get(), head(), post() and
+mirror(), will all dispatch the request they build via this method.
+They are convenience methods that simply hides the creation of the
+request object for you.
+
+The $content_file, $content_cb and $read_size_hint all correspond to
+options described with the get() method above.
+
+You are allowed to use a CODE reference as C<content> in the request
+object passed in. The C<content> function should return the content
+when called. The content can be returned in chunks. The content
+function will be invoked repeatedly until it return an empty string to
+signal that there is no more content.
+
+=item $ua->simple_request( $request )
+
+=item $ua->simple_request( $request, $content_file )
+
+=item $ua->simple_request( $request, $content_cb )
+
+=item $ua->simple_request( $request, $content_cb, $read_size_hint )
+
+This method dispatches a single request and returns the response
+received. Arguments are the same as for request() described above.
+
+The difference from request() is that simple_request() will not try to
+handle redirects or authentication responses. The request() method
+will in fact invoke this method for each simple request it sends.
+
+=item $ua->is_online
+
+Tries to determine if you have access to the Internet. Returns
+TRUE if the built-in heuristics determine that the user agent is
+able to access the Internet (over HTTP). See also L<LWP::Online>.
+
+=item $ua->is_protocol_supported( $scheme )
+
+You can use this method to test whether this user agent object supports the
+specified C<scheme>. (The C<scheme> might be a string (like 'http' or
+'ftp') or it might be an URI object reference.)
+
+Whether a scheme is supported, is determined by the user agent's
+C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
+the capabilities of LWP. I.e., this will return TRUE only if LWP
+supports this protocol I<and> it's permitted for this particular
+object.
+
+=back
+
+=head2 Callback methods
+
+The following methods will be invoked as requests are processed. These
+methods are documented here because subclasses of C<LWP::UserAgent>
+might want to override their behaviour.
+
+=over
+
+=item $ua->prepare_request( $request )
+
+This method is invoked by simple_request(). Its task is to modify the
+given $request object by setting up various headers based on the
+attributes of the user agent. The return value should normally be the
+$request object passed in. If a different request object is returned
+it will be the one actually processed.
+
+The headers affected by the base implementation are; "User-Agent",
+"From", "Range" and "Cookie".
+
+=item $ua->redirect_ok( $prospective_request, $response )
+
+This method is called by request() before it tries to follow a
+redirection to the request in $response. This should return a TRUE
+value if this redirection is permissible. The $prospective_request
+will be the request to be sent if this method returns TRUE.
+
+The base implementation will return FALSE unless the method
+is in the object's C<requests_redirectable> list,
+FALSE if the proposed redirection is to a "file://..."
+URL, and TRUE otherwise.
+
+=item $ua->get_basic_credentials( $realm, $uri, $isproxy )
+
+This is called by request() to retrieve credentials for documents
+protected by Basic or Digest Authentication. The arguments passed in
+is the $realm provided by the server, the $uri requested and a boolean
+flag to indicate if this is authentication against a proxy server.
+
+The method should return a username and password. It should return an
+empty list to abort the authentication resolution attempt. Subclasses
+can override this method to prompt the user for the information. An
+example of this can be found in C<lwp-request> program distributed
+with this library.
+
+The base implementation simply checks a set of pre-stored member
+variables, set up with the credentials() method.
+
+=item $ua->progress( $status, $request_or_response )
+
+This is called frequently as the response is received regardless of
+how the content is processed. The method is called with $status
+"begin" at the start of processing the request and with $state "end"
+before the request method returns. In between these $status will be
+the fraction of the response currently received or the string "tick"
+if the fraction can't be calculated.
+
+When $status is "begin" the second argument is the request object,
+otherwise it is the response object.
+
+=back
+
+=head1 SEE ALSO
+
+See L<LWP> for a complete overview of libwww-perl5. See L<lwpcook>
+and the scripts F<lwp-request> and F<lwp-download> for examples of
+usage.
+
+See L<HTTP::Request> and L<HTTP::Response> for a description of the
+message objects dispatched and received. See L<HTTP::Request::Common>
+and L<HTML::Form> for other ways to build request objects.
+
+See L<WWW::Mechanize> and L<WWW::Search> for examples of more
+specialized user agents based on C<LWP::UserAgent>.
+
+=head1 COPYRIGHT
+
+Copyright 1995-2009 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
--- /dev/null
+package WWW::Mechanize;
+
+=head1 NAME
+
+WWW::Mechanize - Handy web browsing in a Perl object
+
+=head1 VERSION
+
+Version 1.70
+
+=cut
+
+our $VERSION = '1.72';
+
+=head1 SYNOPSIS
+
+C<WWW::Mechanize>, or Mech for short, is a Perl module for stateful
+programmatic web browsing, used for automating interaction with
+websites.
+
+Features include:
+
+=over 4
+
+=item * All HTTP methods
+
+=item * High-level hyperlink and HTML form support, without having to parse HTML yourself
+
+=item * SSL support
+
+=item * Automatic cookies
+
+=item * Custom HTTP headers
+
+=item * Automatic handling of redirections
+
+=item * Proxies
+
+=item * HTTP authentication
+
+=back
+
+Mech supports performing a sequence of page fetches including
+following links and submitting forms. Each fetched page is parsed
+and its links and forms are extracted. A link or a form can be
+selected, form fields can be filled and the next page can be fetched.
+Mech also stores a history of the URLs you've visited, which can
+be queried and revisited.
+
+ use WWW::Mechanize;
+ my $mech = WWW::Mechanize->new();
+
+ $mech->get( $url );
+
+ $mech->follow_link( n => 3 );
+ $mech->follow_link( text_regex => qr/download this/i );
+ $mech->follow_link( url => 'http://host.com/index.html' );
+
+ $mech->submit_form(
+ form_number => 3,
+ fields => {
+ username => 'mungo',
+ password => 'lost-and-alone',
+ }
+ );
+
+ $mech->submit_form(
+ form_name => 'search',
+ fields => { query => 'pot of gold', },
+ button => 'Search Now'
+ );
+
+
+Mech is well suited for use in testing web applications. If you use
+one of the Test::*, like L<Test::HTML::Lint> modules, you can check the
+fetched content and use that as input to a test call.
+
+ use Test::More;
+ like( $mech->content(), qr/$expected/, "Got expected content" );
+
+Each page fetch stores its URL in a history stack which you can
+traverse.
+
+ $mech->back();
+
+If you want finer control over your page fetching, you can use
+these methods. C<follow_link> and C<submit_form> are just high
+level wrappers around them.
+
+ $mech->find_link( n => $number );
+ $mech->form_number( $number );
+ $mech->form_name( $name );
+ $mech->field( $name, $value );
+ $mech->set_fields( %field_values );
+ $mech->set_visible( @criteria );
+ $mech->click( $button );
+
+L<WWW::Mechanize> is a proper subclass of L<LWP::UserAgent> and
+you can also use any of L<LWP::UserAgent>'s methods.
+
+ $mech->add_header($name => $value);
+
+Please note that Mech does NOT support JavaScript, you need additional software
+for that. Please check L<WWW::Mechanize::FAQ/"JavaScript"> for more.
+
+=head1 IMPORTANT LINKS
+
+=over 4
+
+=item * L<http://code.google.com/p/www-mechanize/issues/list>
+
+The queue for bugs & enhancements in WWW::Mechanize and
+Test::WWW::Mechanize. Please note that the queue at L<http://rt.cpan.org>
+is no longer maintained.
+
+=item * L<http://search.cpan.org/dist/WWW-Mechanize/>
+
+The CPAN documentation page for Mechanize.
+
+=item * L<http://search.cpan.org/dist/WWW-Mechanize/lib/WWW/Mechanize/FAQ.pod>
+
+Frequently asked questions. Make sure you read here FIRST.
+
+=back
+
+=cut
+
+use strict;
+use warnings;
+
+use HTTP::Request 1.30;
+use LWP::UserAgent 5.827;
+use HTML::Form 1.00;
+use HTML::TokeParser;
+
+use base 'LWP::UserAgent';
+
+our $HAS_ZLIB;
+BEGIN {
+ $HAS_ZLIB = eval 'use Compress::Zlib (); 1;';
+}
+
+=head1 CONSTRUCTOR AND STARTUP
+
+=head2 new()
+
+Creates and returns a new WWW::Mechanize object, hereafter referred to as
+the "agent".
+
+ my $mech = WWW::Mechanize->new()
+
+The constructor for WWW::Mechanize overrides two of the parms to the
+LWP::UserAgent constructor:
+
+ agent => 'WWW-Mechanize/#.##'
+ cookie_jar => {} # an empty, memory-only HTTP::Cookies object
+
+You can override these overrides by passing parms to the constructor,
+as in:
+
+ my $mech = WWW::Mechanize->new( agent => 'wonderbot 1.01' );
+
+If you want none of the overhead of a cookie jar, or don't want your
+bot accepting cookies, you have to explicitly disallow it, like so:
+
+ my $mech = WWW::Mechanize->new( cookie_jar => undef );
+
+Here are the parms that WWW::Mechanize recognizes. These do not include
+parms that L<LWP::UserAgent> recognizes.
+
+=over 4
+
+=item * C<< autocheck => [0|1] >>
+
+Checks each request made to see if it was successful. This saves
+you the trouble of manually checking yourself. Any errors found
+are errors, not warnings.
+
+The default value is ON, unless it's being subclassed, in which
+case it is OFF. This means that standalone L<WWW::Mechanize>instances
+have autocheck turned on, which is protective for the vast majority
+of Mech users who don't bother checking the return value of get()
+and post() and can't figure why their code fails. However, if
+L<WWW::Mechanize> is subclassed, such as for L<Test::WWW::Mechanize>
+or L<Test::WWW::Mechanize::Catalyst>, this may not be an appropriate
+default, so it's off.
+
+=item * C<< noproxy => [0|1] >>
+
+Turn off the automatic call to the L<LWP::UserAgent> C<env_proxy> function.
+
+This needs to be explicitly turned off if you're using L<Crypt::SSLeay> to
+access a https site via a proxy server. Note: you still need to set your
+HTTPS_PROXY environment variable as appropriate.
+
+=item * C<< onwarn => \&func >>
+
+Reference to a C<warn>-compatible function, such as C<< L<Carp>::carp >>,
+that is called when a warning needs to be shown.
+
+If this is set to C<undef>, no warnings will ever be shown. However,
+it's probably better to use the C<quiet> method to control that behavior.
+
+If this value is not passed, Mech uses C<Carp::carp> if L<Carp> is
+installed, or C<CORE::warn> if not.
+
+=item * C<< onerror => \&func >>
+
+Reference to a C<die>-compatible function, such as C<< L<Carp>::croak >>,
+that is called when there's a fatal error.
+
+If this is set to C<undef>, no errors will ever be shown.
+
+If this value is not passed, Mech uses C<Carp::croak> if L<Carp> is
+installed, or C<CORE::die> if not.
+
+=item * C<< quiet => [0|1] >>
+
+Don't complain on warnings. Setting C<< quiet => 1 >> is the same as
+calling C<< $mech->quiet(1) >>. Default is off.
+
+=item * C<< stack_depth => $value >>
+
+Sets the depth of the page stack that keeps track of all the
+downloaded pages. Default is effectively infinite stack size. If
+the stack is eating up your memory, then set this to a smaller
+number, say 5 or 10. Setting this to zero means Mech will keep no
+history.
+
+=back
+
+To support forms, WWW::Mechanize's constructor pushes POST
+on to the agent's C<requests_redirectable> list (see also
+L<LWP::UserAgent>.)
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ my %parent_parms = (
+ agent => "WWW-Mechanize/$VERSION",
+ cookie_jar => {},
+ );
+
+ my %mech_parms = (
+ autocheck => ($class eq 'WWW::Mechanize' ? 1 : 0),
+ onwarn => \&WWW::Mechanize::_warn,
+ onerror => \&WWW::Mechanize::_die,
+ quiet => 0,
+ stack_depth => 8675309, # Arbitrarily humongous stack
+ headers => {},
+ noproxy => 0,
+ );
+
+ my %passed_parms = @_;
+
+ # Keep the mech-specific parms before creating the object.
+ while ( my($key,$value) = each %passed_parms ) {
+ if ( exists $mech_parms{$key} ) {
+ $mech_parms{$key} = $value;
+ }
+ else {
+ $parent_parms{$key} = $value;
+ }
+ }
+
+ my $self = $class->SUPER::new( %parent_parms );
+ bless $self, $class;
+
+ # Use the mech parms now that we have a mech object.
+ for my $parm ( keys %mech_parms ) {
+ $self->{$parm} = $mech_parms{$parm};
+ }
+ $self->{page_stack} = [];
+ $self->env_proxy() unless $mech_parms{noproxy};
+
+ # libwww-perl 5.800 (and before, I assume) has a problem where
+ # $ua->{proxy} can be undef and clone() doesn't handle it.
+ $self->{proxy} = {} unless defined $self->{proxy};
+ push( @{$self->requests_redirectable}, 'POST' );
+
+ $self->_reset_page();
+
+ return $self;
+}
+
+=head2 $mech->agent_alias( $alias )
+
+Sets the user agent string to the expanded version from a table of actual user strings.
+I<$alias> can be one of the following:
+
+=over 4
+
+=item * Windows IE 6
+
+=item * Windows Mozilla
+
+=item * Mac Safari
+
+=item * Mac Mozilla
+
+=item * Linux Mozilla
+
+=item * Linux Konqueror
+
+=back
+
+then it will be replaced with a more interesting one. For instance,
+
+ $mech->agent_alias( 'Windows IE 6' );
+
+sets your User-Agent to
+
+ Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)
+
+The list of valid aliases can be returned from C<known_agent_aliases()>. The current list is:
+
+=over
+
+=item * Windows IE 6
+
+=item * Windows Mozilla
+
+=item * Mac Safari
+
+=item * Mac Mozilla
+
+=item * Linux Mozilla
+
+=item * Linux Konqueror
+
+=back
+
+=cut
+
+my %known_agents = (
+ 'Windows IE 6' => 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)',
+ 'Windows Mozilla' => 'Mozilla/5.0 (Windows; U; Windows NT 5.0; en-US; rv:1.4b) Gecko/20030516 Mozilla Firebird/0.6',
+ 'Mac Safari' => 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85 (KHTML, like Gecko) Safari/85',
+ 'Mac Mozilla' => 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X Mach-O; en-US; rv:1.4a) Gecko/20030401',
+ 'Linux Mozilla' => 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.4) Gecko/20030624',
+ 'Linux Konqueror' => 'Mozilla/5.0 (compatible; Konqueror/3; Linux)',
+);
+
+sub agent_alias {
+ my $self = shift;
+ my $alias = shift;
+
+ if ( defined $known_agents{$alias} ) {
+ return $self->agent( $known_agents{$alias} );
+ }
+ else {
+ $self->warn( qq{Unknown agent alias "$alias"} );
+ return $self->agent();
+ }
+}
+
+=head2 known_agent_aliases()
+
+Returns a list of all the agent aliases that Mech knows about.
+
+=cut
+
+sub known_agent_aliases {
+ return sort keys %known_agents;
+}
+
+=head1 PAGE-FETCHING METHODS
+
+=head2 $mech->get( $uri )
+
+Given a URL/URI, fetches it. Returns an L<HTTP::Response> object.
+I<$uri> can be a well-formed URL string, a L<URI> object, or a
+L<WWW::Mechanize::Link> object.
+
+The results are stored internally in the agent object, but you don't
+know that. Just use the accessors listed below. Poking at the
+internals is deprecated and subject to change in the future.
+
+C<get()> is a well-behaved overloaded version of the method in
+L<LWP::UserAgent>. This lets you do things like
+
+ $mech->get( $uri, ':content_file' => $tempfile );
+
+and you can rest assured that the parms will get filtered down
+appropriately.
+
+B<NOTE:> Because C<:content_file> causes the page contents to be
+stored in a file instead of the response object, some Mech functions
+that expect it to be there won't work as expected. Use with caution.
+
+=cut
+
+sub get {
+ my $self = shift;
+ my $uri = shift;
+
+ $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link';
+
+ $uri = $self->base
+ ? URI->new_abs( $uri, $self->base )
+ : URI->new( $uri );
+
+ # It appears we are returning a super-class method,
+ # but it in turn calls the request() method here in Mechanize
+ return $self->SUPER::get( $uri->as_string, @_ );
+}
+
+=head2 $mech->put( $uri, content => $content )
+
+PUTs I<$content> to $uri. Returns an L<HTTP::Response> object.
+I<$uri> can be a well-formed URI string, a L<URI> object, or a
+L<WWW::Mechanize::Link> object.
+
+=cut
+
+sub put {
+ my $self = shift;
+ my $uri = shift;
+
+ $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link';
+
+ $uri = $self->base
+ ? URI->new_abs( $uri, $self->base )
+ : URI->new( $uri );
+
+ # It appears we are returning a super-class method,
+ # but it in turn calls the request() method here in Mechanize
+ return $self->_SUPER_put( $uri->as_string, @_ );
+}
+
+
+# Added until LWP::UserAgent has it.
+sub _SUPER_put {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters,1);
+ return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
+}
+
+=head2 $mech->reload()
+
+Acts like the reload button in a browser: repeats the current
+request. The history (as per the L</back> method) is not altered.
+
+Returns the L<HTTP::Response> object from the reload, or C<undef>
+if there's no current request.
+
+=cut
+
+sub reload {
+ my $self = shift;
+
+ return unless my $req = $self->{req};
+
+ return $self->_update_page( $req, $self->_make_request( $req, @_ ) );
+}
+
+=head2 $mech->back()
+
+The equivalent of hitting the "back" button in a browser. Returns to
+the previous page. Won't go back past the first page. (Really, what
+would it do if it could?)
+
+Returns true if it could go back, or false if not.
+
+=cut
+
+sub back {
+ my $self = shift;
+
+ my $stack = $self->{page_stack};
+ return unless $stack && @{$stack};
+
+ my $popped = pop @{$self->{page_stack}};
+ my $req = $popped->{req};
+ my $res = $popped->{res};
+
+ $self->_update_page( $req, $res );
+
+ return 1;
+}
+
+=head1 STATUS METHODS
+
+=head2 $mech->success()
+
+Returns a boolean telling whether the last request was successful.
+If there hasn't been an operation yet, returns false.
+
+This is a convenience function that wraps C<< $mech->res->is_success >>.
+
+=cut
+
+sub success {
+ my $self = shift;
+
+ return $self->res && $self->res->is_success;
+}
+
+
+=head2 $mech->uri()
+
+Returns the current URI as a L<URI> object. This object stringifies
+to the URI itself.
+
+=head2 $mech->response() / $mech->res()
+
+Return the current response as an L<HTTP::Response> object.
+
+Synonym for C<< $mech->response() >>
+
+=head2 $mech->status()
+
+Returns the HTTP status code of the response. This is a 3-digit
+number like 200 for OK, 404 for not found, and so on.
+
+=head2 $mech->ct() / $mech->content_type()
+
+Returns the content type of the response.
+
+=head2 $mech->base()
+
+Returns the base URI for the current response
+
+=head2 $mech->forms()
+
+When called in a list context, returns a list of the forms found in
+the last fetched page. In a scalar context, returns a reference to
+an array with those forms. The forms returned are all L<HTML::Form>
+objects.
+
+=head2 $mech->current_form()
+
+Returns the current form as an L<HTML::Form> object.
+
+=head2 $mech->links()
+
+When called in a list context, returns a list of the links found in the
+last fetched page. In a scalar context it returns a reference to an array
+with those links. Each link is a L<WWW::Mechanize::Link> object.
+
+=head2 $mech->is_html()
+
+Returns true/false on whether our content is HTML, according to the
+HTTP headers.
+
+=cut
+
+sub uri {
+ my $self = shift;
+ return $self->response->request->uri;
+}
+
+sub res { my $self = shift; return $self->{res}; }
+sub response { my $self = shift; return $self->{res}; }
+sub status { my $self = shift; return $self->{status}; }
+sub ct { my $self = shift; return $self->{ct}; }
+sub content_type { my $self = shift; return $self->{ct}; }
+sub base { my $self = shift; return $self->{base}; }
+sub is_html {
+ my $self = shift;
+ return defined $self->ct &&
+ ($self->ct eq 'text/html' || $self->ct eq 'application/xhtml+xml');
+}
+
+=head2 $mech->title()
+
+Returns the contents of the C<< <TITLE> >> tag, as parsed by
+L<HTML::HeadParser>. Returns undef if the content is not HTML.
+
+=cut
+
+sub title {
+ my $self = shift;
+
+ return unless $self->is_html;
+
+ if ( not defined $self->{title} ) {
+ require HTML::HeadParser;
+ my $p = HTML::HeadParser->new;
+ $p->parse($self->content);
+ $self->{title} = $p->header('Title');
+ }
+ return $self->{title};
+}
+
+=head1 CONTENT-HANDLING METHODS
+
+=head2 $mech->content(...)
+
+Returns the content that the mech uses internally for the last page
+fetched. Ordinarily this is the same as $mech->response()->content(),
+but this may differ for HTML documents if L</update_html> is
+overloaded (in which case the value passed to the base-class
+implementation of same will be returned), and/or extra named arguments
+are passed to I<content()>:
+
+=over 2
+
+=item I<< $mech->content( format => 'text' ) >>
+
+Returns a text-only version of the page, with all HTML markup
+stripped. This feature requires I<HTML::TreeBuilder> to be installed,
+or a fatal error will be thrown.
+
+=item I<< $mech->content( base_href => [$base_href|undef] ) >>
+
+Returns the HTML document, modified to contain a
+C<< <base href="$base_href"> >> mark-up in the header.
+I<$base_href> is C<< $mech->base() >> if not specified. This is
+handy to pass the HTML to e.g. L<HTML::Display>.
+
+=back
+
+Passing arguments to C<content()> if the current document is not
+HTML has no effect now (i.e. the return value is the same as
+C<< $self->response()->content() >>. This may change in the future,
+but will likely be backwards-compatible when it does.
+
+=cut
+
+sub content {
+ my $self = shift;
+ my $content = $self->{content};
+
+ if ( $self->is_html ) {
+ my %parms = @_;
+
+ if ( exists $parms{base_href} ) {
+ my $base_href = (delete $parms{base_href}) || $self->base;
+ $content=~s/<head>/<head>\n<base href="$base_href">/i;
+ }
+
+ if ( my $format = delete $parms{format} ) {
+ if ( $format eq 'text' ) {
+ $content = $self->text;
+ }
+ else {
+ $self->die( qq{Unknown "format" parameter "$format"} );
+ }
+ }
+
+ $self->_check_unhandled_parms( %parms );
+ }
+
+ return $content;
+}
+
+=head2 $mech->text()
+
+Returns the text of the current HTML content. If the content isn't
+HTML, $mech will die.
+
+The text is extracted by parsing the content, and then the extracted
+text is cached, so don't worry about performance of calling this
+repeatedly.
+
+=cut
+
+sub text {
+ my $self = shift;
+
+ if ( not defined $self->{text} ) {
+ require HTML::TreeBuilder;
+ my $tree = HTML::TreeBuilder->new();
+ $tree->parse( $self->content );
+ $tree->eof();
+ $tree->elementify(); # just for safety
+ $self->{text} = $tree->as_text();
+ $tree->delete;
+ }
+
+ return $self->{text};
+}
+
+sub _check_unhandled_parms {
+ my $self = shift;
+ my %parms = @_;
+
+ for my $cmd ( sort keys %parms ) {
+ $self->die( qq{Unknown named argument "$cmd"} );
+ }
+}
+
+=head1 LINK METHODS
+
+=head2 $mech->links()
+
+Lists all the links on the current page. Each link is a
+WWW::Mechanize::Link object. In list context, returns a list of all
+links. In scalar context, returns an array reference of all links.
+
+=cut
+
+sub links {
+ my $self = shift;
+
+ $self->_extract_links() unless $self->{links};
+
+ return @{$self->{links}} if wantarray;
+ return $self->{links};
+}
+
+=head2 $mech->follow_link(...)
+
+Follows a specified link on the page. You specify the match to be
+found using the same parms that C<L<find_link()>> uses.
+
+Here some examples:
+
+=over 4
+
+=item * 3rd link called "download"
+
+ $mech->follow_link( text => 'download', n => 3 );
+
+=item * first link where the URL has "download" in it, regardless of case:
+
+ $mech->follow_link( url_regex => qr/download/i );
+
+or
+
+ $mech->follow_link( url_regex => qr/(?i:download)/ );
+
+=item * 3rd link on the page
+
+ $mech->follow_link( n => 3 );
+
+=back
+
+Returns the result of the GET method (an HTTP::Response object) if
+a link was found. If the page has no links, or the specified link
+couldn't be found, returns undef.
+
+=cut
+
+sub follow_link {
+ my $self = shift;
+ my %parms = ( n=>1, @_ );
+
+ if ( $parms{n} eq 'all' ) {
+ delete $parms{n};
+ $self->warn( q{follow_link(n=>"all") is not valid} );
+ }
+
+ my $link = $self->find_link(%parms);
+ if ( $link ) {
+ return $self->get( $link->url );
+ }
+
+ if ( $self->{autocheck} ) {
+ $self->die( 'Link not found' );
+ }
+
+ return;
+}
+
+=head2 $mech->find_link( ... )
+
+Finds a link in the currently fetched page. It returns a
+L<WWW::Mechanize::Link> object which describes the link. (You'll
+probably be most interested in the C<url()> property.) If it fails
+to find a link it returns undef.
+
+You can take the URL part and pass it to the C<get()> method. If
+that's your plan, you might as well use the C<follow_link()> method
+directly, since it does the C<get()> for you automatically.
+
+Note that C<< <FRAME SRC="..."> >> tags are parsed out of the the HTML
+and treated as links so this method works with them.
+
+You can select which link to find by passing in one or more of these
+key/value pairs:
+
+=over 4
+
+=item * C<< text => 'string', >> and C<< text_regex => qr/regex/, >>
+
+C<text> matches the text of the link against I<string>, which must be an
+exact match. To select a link with text that is exactly "download", use
+
+ $mech->find_link( text => 'download' );
+
+C<text_regex> matches the text of the link against I<regex>. To select a
+link with text that has "download" anywhere in it, regardless of case, use
+
+ $mech->find_link( text_regex => qr/download/i );
+
+Note that the text extracted from the page's links are trimmed. For
+example, C<< <a> foo </a> >> is stored as 'foo', and searching for
+leading or trailing spaces will fail.
+
+=item * C<< url => 'string', >> and C<< url_regex => qr/regex/, >>
+
+Matches the URL of the link against I<string> or I<regex>, as appropriate.
+The URL may be a relative URL, like F<foo/bar.html>, depending on how
+it's coded on the page.
+
+=item * C<< url_abs => string >> and C<< url_abs_regex => regex >>
+
+Matches the absolute URL of the link against I<string> or I<regex>,
+as appropriate. The URL will be an absolute URL, even if it's relative
+in the page.
+
+=item * C<< name => string >> and C<< name_regex => regex >>
+
+Matches the name of the link against I<string> or I<regex>, as appropriate.
+
+=item * C<< id => string >> and C<< id_regex => regex >>
+
+Matches the attribute 'id' of the link against I<string> or
+I<regex>, as appropriate.
+
+=item * C<< class => string >> and C<< class_regex => regex >>
+
+Matches the attribute 'class' of the link against I<string> or
+I<regex>, as appropriate.
+
+=item * C<< tag => string >> and C<< tag_regex => regex >>
+
+Matches the tag that the link came from against I<string> or I<regex>,
+as appropriate. The C<tag_regex> is probably most useful to check for
+more than one tag, as in:
+
+ $mech->find_link( tag_regex => qr/^(a|frame)$/ );
+
+The tags and attributes looked at are defined below, at
+L<< $mech->find_link() : link format >>.
+
+=back
+
+If C<n> is not specified, it defaults to 1. Therefore, if you don't
+specify any parms, this method defaults to finding the first link on the
+page.
+
+Note that you can specify multiple text or URL parameters, which
+will be ANDed together. For example, to find the first link with
+text of "News" and with "cnn.com" in the URL, use:
+
+ $mech->find_link( text => 'News', url_regex => qr/cnn\.com/ );
+
+The return value is a reference to an array containing a
+L<WWW::Mechanize::Link> object for every link in C<< $self->content >>.
+
+The links come from the following:
+
+=over 4
+
+=item C<< <a href=...> >>
+
+=item C<< <area href=...> >>
+
+=item C<< <frame src=...> >>
+
+=item C<< <iframe src=...> >>
+
+=item C<< <link href=...> >>
+
+=item C<< <meta content=...> >>
+
+=back
+
+=cut
+
+sub find_link {
+ my $self = shift;
+ my %parms = ( n=>1, @_ );
+
+ my $wantall = ( $parms{n} eq 'all' );
+
+ $self->_clean_keys( \%parms, qr/^(n|(text|url|url_abs|name|tag|id|class)(_regex)?)$/ );
+
+ my @links = $self->links or return;
+
+ my $nmatches = 0;
+ my @matches;
+ for my $link ( @links ) {
+ if ( _match_any_link_parms($link,\%parms) ) {
+ if ( $wantall ) {
+ push( @matches, $link );
+ }
+ else {
+ ++$nmatches;
+ return $link if $nmatches >= $parms{n};
+ }
+ }
+ } # for @links
+
+ if ( $wantall ) {
+ return @matches if wantarray;
+ return \@matches;
+ }
+
+ return;
+} # find_link
+
+# Used by find_links to check for matches
+# The logic is such that ALL parm criteria that are given must match
+sub _match_any_link_parms {
+ my $link = shift;
+ my $p = shift;
+
+ # No conditions, anything matches
+ return 1 unless keys %$p;
+
+ return if defined $p->{url} && !($link->url eq $p->{url} );
+ return if defined $p->{url_regex} && !($link->url =~ $p->{url_regex} );
+ return if defined $p->{url_abs} && !($link->url_abs eq $p->{url_abs} );
+ return if defined $p->{url_abs_regex} && !($link->url_abs =~ $p->{url_abs_regex} );
+ return if defined $p->{text} && !(defined($link->text) && $link->text eq $p->{text} );
+ return if defined $p->{text_regex} && !(defined($link->text) && $link->text =~ $p->{text_regex} );
+ return if defined $p->{name} && !(defined($link->name) && $link->name eq $p->{name} );
+ return if defined $p->{name_regex} && !(defined($link->name) && $link->name =~ $p->{name_regex} );
+ return if defined $p->{tag} && !($link->tag && $link->tag eq $p->{tag} );
+ return if defined $p->{tag_regex} && !($link->tag && $link->tag =~ $p->{tag_regex} );
+
+ return if defined $p->{id} && !($link->attrs->{id} && $link->attrs->{id} eq $p->{id} );
+ return if defined $p->{id_regex} && !($link->attrs->{id} && $link->attrs->{id} =~ $p->{id_regex} );
+ return if defined $p->{class} && !($link->attrs->{class} && $link->attrs->{class} eq $p->{class} );
+ return if defined $p->{class_regex} && !($link->attrs->{class} && $link->attrs->{class} =~ $p->{class_regex} );
+
+ # Success: everything that was defined passed.
+ return 1;
+
+}
+
+# Cleans the %parms parameter for the find_link and find_image methods.
+sub _clean_keys {
+ my $self = shift;
+ my $parms = shift;
+ my $rx_keyname = shift;
+
+ for my $key ( keys %$parms ) {
+ my $val = $parms->{$key};
+ if ( $key !~ qr/$rx_keyname/ ) {
+ $self->warn( qq{Unknown link-finding parameter "$key"} );
+ delete $parms->{$key};
+ next;
+ }
+
+ my $key_regex = ( $key =~ /_regex$/ );
+ my $val_regex = ( ref($val) eq 'Regexp' );
+
+ if ( $key_regex ) {
+ if ( !$val_regex ) {
+ $self->warn( qq{$val passed as $key is not a regex} );
+ delete $parms->{$key};
+ next;
+ }
+ }
+ else {
+ if ( $val_regex ) {
+ $self->warn( qq{$val passed as '$key' is a regex} );
+ delete $parms->{$key};
+ next;
+ }
+ if ( $val =~ /^\s|\s$/ ) {
+ $self->warn( qq{'$val' is space-padded and cannot succeed} );
+ delete $parms->{$key};
+ next;
+ }
+ }
+ } # for keys %parms
+
+ return;
+} # _clean_keys()
+
+
+=head2 $mech->find_all_links( ... )
+
+Returns all the links on the current page that match the criteria. The
+method for specifying link criteria is the same as in C<L</find_link()>>.
+Each of the links returned is a L<WWW::Mechanize::Link> object.
+
+In list context, C<find_all_links()> returns a list of the links.
+Otherwise, it returns a reference to the list of links.
+
+C<find_all_links()> with no parameters returns all links in the
+page.
+
+=cut
+
+sub find_all_links {
+ my $self = shift;
+ return $self->find_link( @_, n=>'all' );
+}
+
+=head2 $mech->find_all_inputs( ... criteria ... )
+
+find_all_inputs() returns an array of all the input controls in the
+current form whose properties match all of the regexes passed in.
+The controls returned are all descended from HTML::Form::Input.
+
+If no criteria are passed, all inputs will be returned.
+
+If there is no current page, there is no form on the current
+page, or there are no submit controls in the current form
+then the return will be an empty array.
+
+You may use a regex or a literal string:
+
+ # get all textarea controls whose names begin with "customer"
+ my @customer_text_inputs = $mech->find_all_inputs(
+ type => 'textarea',
+ name_regex => qr/^customer/,
+ );
+
+ # get all text or textarea controls called "customer"
+ my @customer_text_inputs = $mech->find_all_inputs(
+ type_regex => qr/^(text|textarea)$/,
+ name => 'customer',
+ );
+
+=cut
+
+sub find_all_inputs {
+ my $self = shift;
+ my %criteria = @_;
+
+ my $form = $self->current_form() or return;
+
+ my @found;
+ foreach my $input ( $form->inputs ) { # check every pattern for a match on the current hash
+ my $matched = 1;
+ foreach my $criterion ( sort keys %criteria ) { # Sort so we're deterministic
+ my $field = $criterion;
+ my $is_regex = ( $field =~ s/(?:_regex)$// );
+ my $what = $input->{$field};
+ $matched = defined($what) && (
+ $is_regex
+ ? ( $what =~ $criteria{$criterion} )
+ : ( $what eq $criteria{$criterion} )
+ );
+ last if !$matched;
+ }
+ push @found, $input if $matched;
+ }
+ return @found;
+}
+
+=head2 $mech->find_all_submits( ... criteria ... )
+
+C<find_all_submits()> does the same thing as C<find_all_inputs()>
+except that it only returns controls that are submit controls,
+ignoring other types of input controls like text and checkboxes.
+
+=cut
+
+sub find_all_submits {
+ my $self = shift;
+
+ return $self->find_all_inputs( @_, type_regex => qr/^(submit|image)$/ );
+}
+
+
+=head1 IMAGE METHODS
+
+=head2 $mech->images
+
+Lists all the images on the current page. Each image is a
+WWW::Mechanize::Image object. In list context, returns a list of all
+images. In scalar context, returns an array reference of all images.
+
+=cut
+
+sub images {
+ my $self = shift;
+
+ $self->_extract_images() unless $self->{images};
+
+ return @{$self->{images}} if wantarray;
+ return $self->{images};
+}
+
+=head2 $mech->find_image()
+
+Finds an image in the current page. It returns a
+L<WWW::Mechanize::Image> object which describes the image. If it fails
+to find an image it returns undef.
+
+You can select which image to find by passing in one or more of these
+key/value pairs:
+
+=over 4
+
+=item * C<< alt => 'string' >> and C<< alt_regex => qr/regex/, >>
+
+C<alt> matches the ALT attribute of the image against I<string>, which must be an
+exact match. To select a image with an ALT tag that is exactly "download", use
+
+ $mech->find_image( alt => 'download' );
+
+C<alt_regex> matches the ALT attribute of the image against a regular
+expression. To select an image with an ALT attribute that has "download"
+anywhere in it, regardless of case, use
+
+ $mech->find_image( alt_regex => qr/download/i );
+
+=item * C<< url => 'string', >> and C<< url_regex => qr/regex/, >>
+
+Matches the URL of the image against I<string> or I<regex>, as appropriate.
+The URL may be a relative URL, like F<foo/bar.html>, depending on how
+it's coded on the page.
+
+=item * C<< url_abs => string >> and C<< url_abs_regex => regex >>
+
+Matches the absolute URL of the image against I<string> or I<regex>,
+as appropriate. The URL will be an absolute URL, even if it's relative
+in the page.
+
+=item * C<< tag => string >> and C<< tag_regex => regex >>
+
+Matches the tag that the image came from against I<string> or I<regex>,
+as appropriate. The C<tag_regex> is probably most useful to check for
+more than one tag, as in:
+
+ $mech->find_image( tag_regex => qr/^(img|input)$/ );
+
+The tags supported are C<< <img> >> and C<< <input> >>.
+
+=back
+
+If C<n> is not specified, it defaults to 1. Therefore, if you don't
+specify any parms, this method defaults to finding the first image on the
+page.
+
+Note that you can specify multiple ALT or URL parameters, which
+will be ANDed together. For example, to find the first image with
+ALT text of "News" and with "cnn.com" in the URL, use:
+
+ $mech->find_image( image => 'News', url_regex => qr/cnn\.com/ );
+
+The return value is a reference to an array containing a
+L<WWW::Mechanize::Image> object for every image in C<< $self->content >>.
+
+=cut
+
+sub find_image {
+ my $self = shift;
+ my %parms = ( n=>1, @_ );
+
+ my $wantall = ( $parms{n} eq 'all' );
+
+ $self->_clean_keys( \%parms, qr/^(n|(alt|url|url_abs|tag)(_regex)?)$/ );
+
+ my @images = $self->images or return;
+
+ my $nmatches = 0;
+ my @matches;
+ for my $image ( @images ) {
+ if ( _match_any_image_parms($image,\%parms) ) {
+ if ( $wantall ) {
+ push( @matches, $image );
+ }
+ else {
+ ++$nmatches;
+ return $image if $nmatches >= $parms{n};
+ }
+ }
+ } # for @images
+
+ if ( $wantall ) {
+ return @matches if wantarray;
+ return \@matches;
+ }
+
+ return;
+}
+
+# Used by find_images to check for matches
+# The logic is such that ALL parm criteria that are given must match
+sub _match_any_image_parms {
+ my $image = shift;
+ my $p = shift;
+
+ # No conditions, anything matches
+ return 1 unless keys %$p;
+
+ return if defined $p->{url} && !($image->url eq $p->{url} );
+ return if defined $p->{url_regex} && !($image->url =~ $p->{url_regex} );
+ return if defined $p->{url_abs} && !($image->url_abs eq $p->{url_abs} );
+ return if defined $p->{url_abs_regex} && !($image->url_abs =~ $p->{url_abs_regex} );
+ return if defined $p->{alt} && !(defined($image->alt) && $image->alt eq $p->{alt} );
+ return if defined $p->{alt_regex} && !(defined($image->alt) && $image->alt =~ $p->{alt_regex} );
+ return if defined $p->{tag} && !($image->tag && $image->tag eq $p->{tag} );
+ return if defined $p->{tag_regex} && !($image->tag && $image->tag =~ $p->{tag_regex} );
+
+ # Success: everything that was defined passed.
+ return 1;
+}
+
+
+=head2 $mech->find_all_images( ... )
+
+Returns all the images on the current page that match the criteria. The
+method for specifying image criteria is the same as in C<L</find_image()>>.
+Each of the images returned is a L<WWW::Mechanize::Image> object.
+
+In list context, C<find_all_images()> returns a list of the images.
+Otherwise, it returns a reference to the list of images.
+
+C<find_all_images()> with no parameters returns all images in the page.
+
+=cut
+
+sub find_all_images {
+ my $self = shift;
+ return $self->find_image( @_, n=>'all' );
+}
+
+=head1 FORM METHODS
+
+These methods let you work with the forms on a page. The idea is
+to choose a form that you'll later work with using the field methods
+below.
+
+=head2 $mech->forms
+
+Lists all the forms on the current page. Each form is an L<HTML::Form>
+object. In list context, returns a list of all forms. In scalar
+context, returns an array reference of all forms.
+
+=cut
+
+sub forms {
+ my $self = shift;
+
+ $self->_extract_forms() unless $self->{forms};
+
+ return @{$self->{forms}} if wantarray;
+ return $self->{forms};
+}
+
+sub current_form {
+ my $self = shift;
+
+ if ( !$self->{current_form} ) {
+ $self->form_number(1);
+ }
+
+ return $self->{current_form};
+}
+
+=head2 $mech->form_number($number)
+
+Selects the I<number>th form on the page as the target for subsequent
+calls to C<L</field()>> and C<L</click()>>. Also returns the form that was
+selected.
+
+If it is found, the form is returned as an L<HTML::Form> object and set internally
+for later use with Mech's form methods such as C<L</field()>> and C<L</click()>>.
+
+Emits a warning and returns undef if no form is found.
+
+The first form is number 1, not zero.
+
+=cut
+
+sub form_number {
+ my ($self, $form) = @_;
+ # XXX Should we die if no $form is defined? Same question for form_name()
+
+ my $forms = $self->forms;
+ if ( $forms->[$form-1] ) {
+ $self->{current_form} = $forms->[$form-1];
+ return $self->{current_form};
+ }
+
+ return;
+}
+
+=head2 $mech->form_name( $name )
+
+Selects a form by name. If there is more than one form on the page
+with that name, then the first one is used, and a warning is
+generated.
+
+If it is found, the form is returned as an L<HTML::Form> object and
+set internally for later use with Mech's form methods such as
+C<L</field()>> and C<L</click()>>.
+
+Returns undef if no form is found.
+
+=cut
+
+sub form_name {
+ my ($self, $form) = @_;
+
+ my $temp;
+ my @matches = grep {defined($temp = $_->attr('name')) and ($temp eq $form) } $self->forms;
+
+ my $nmatches = @matches;
+ if ( $nmatches > 0 ) {
+ if ( $nmatches > 1 ) {
+ $self->warn( "There are $nmatches forms named $form. The first one was used." )
+ }
+ return $self->{current_form} = $matches[0];
+ }
+
+ return;
+}
+
+=head2 $mech->form_id( $name )
+
+Selects a form by ID. If there is more than one form on the page
+with that ID, then the first one is used, and a warning is generated.
+
+If it is found, the form is returned as an L<HTML::Form> object and
+set internally for later use with Mech's form methods such as
+C<L</field()>> and C<L</click()>>.
+
+Returns undef if no form is found.
+
+=cut
+
+sub form_id {
+ my ($self, $formid) = @_;
+
+ my $temp;
+ my @matches = grep { defined($temp = $_->attr('id')) and ($temp eq $formid) } $self->forms;
+ if ( @matches ) {
+ $self->warn( 'There are ', scalar @matches, " forms with ID $formid. The first one was used." )
+ if @matches > 1;
+ return $self->{current_form} = $matches[0];
+ }
+ else {
+ $self->warn( qq{ There is no form with ID "$formid"} );
+ return undef;
+ }
+}
+
+
+=head2 $mech->form_with_fields( @fields )
+
+Selects a form by passing in a list of field names it must contain. If there
+is more than one form on the page with that matches, then the first one is used,
+and a warning is generated.
+
+If it is found, the form is returned as an L<HTML::Form> object and set internally
+for later used with Mech's form methods such as C<L</field()>> and C<L</click()>>.
+
+Returns undef if no form is found.
+
+Note that this functionality requires libwww-perl 5.69 or higher.
+
+=cut
+
+sub form_with_fields {
+ my ($self, @fields) = @_;
+ die 'no fields provided' unless scalar @fields;
+
+ my @matches;
+ FORMS: for my $form (@{ $self->forms }) {
+ my @fields_in_form = $form->param();
+ for my $field (@fields) {
+ next FORMS unless grep { $_ eq $field } @fields_in_form;
+ }
+ push @matches, $form;
+ }
+
+ my $nmatches = @matches;
+ if ( $nmatches > 0 ) {
+ if ( $nmatches > 1 ) {
+ $self->warn( "There are $nmatches forms with the named fields. The first one was used." )
+ }
+ return $self->{current_form} = $matches[0];
+ }
+ else {
+ $self->warn( qq{There is no form with the requested fields} );
+ return undef;
+ }
+}
+
+=head1 FIELD METHODS
+
+These methods allow you to set the values of fields in a given form.
+
+=head2 $mech->field( $name, $value, $number )
+
+=head2 $mech->field( $name, \@values, $number )
+
+Given the name of a field, set its value to the value specified.
+This applies to the current form (as set by the L</form_name()> or
+L</form_number()> method or defaulting to the first form on the
+page).
+
+The optional I<$number> parameter is used to distinguish between two fields
+with the same name. The fields are numbered from 1.
+
+=cut
+
+sub field {
+ my ($self, $name, $value, $number) = @_;
+ $number ||= 1;
+
+ my $form = $self->current_form();
+ if ($number > 1) {
+ $form->find_input($name, undef, $number)->value($value);
+ }
+ else {
+ if ( ref($value) eq 'ARRAY' ) {
+ $form->param($name, $value);
+ }
+ else {
+ $form->value($name => $value);
+ }
+ }
+}
+
+=head2 $mech->select($name, $value)
+
+=head2 $mech->select($name, \@values)
+
+Given the name of a C<select> field, set its value to the value
+specified. If the field is not C<< <select multiple> >> and the
+C<$value> is an array, only the B<first> value will be set. [Note:
+the documentation previously claimed that only the last value would
+be set, but this was incorrect.] Passing C<$value> as a hash with
+an C<n> key selects an item by number (e.g.
+C<< {n => 3} >> or C<< {n => [2,4]} >>).
+The numbering starts at 1. This applies to the current form.
+
+If you have a field with C<< <select multiple> >> and you pass a single
+C<$value>, then C<$value> will be added to the list of fields selected,
+without clearing the others. However, if you pass an array reference,
+then all previously selected values will be cleared.
+
+Returns true on successfully setting the value. On failure, returns
+false and calls C<< $self>warn() >> with an error message.
+
+=cut
+
+sub select {
+ my ($self, $name, $value) = @_;
+
+ my $form = $self->current_form();
+
+ my $input = $form->find_input($name);
+ if (!$input) {
+ $self->warn( qq{Input "$name" not found} );
+ return;
+ }
+
+ if ($input->type ne 'option') {
+ $self->warn( qq{Input "$name" is not type "select"} );
+ return;
+ }
+
+ # For $mech->select($name, {n => 3}) or $mech->select($name, {n => [2,4]}),
+ # transform the 'n' number(s) into value(s) and put it in $value.
+ if (ref($value) eq 'HASH') {
+ for (keys %$value) {
+ $self->warn(qq{Unknown select value parameter "$_"})
+ unless $_ eq 'n';
+ }
+
+ if (defined($value->{n})) {
+ my @inputs = $form->find_input($name, 'option');
+ my @values = ();
+ # distinguish between multiple and non-multiple selects
+ # (see INPUTS section of `perldoc HTML::Form`)
+ if (@inputs == 1) {
+ @values = $inputs[0]->possible_values();
+ }
+ else {
+ foreach my $input (@inputs) {
+ my @possible = $input->possible_values();
+ push @values, pop @possible;
+ }
+ }
+
+ my $n = $value->{n};
+ if (ref($n) eq 'ARRAY') {
+ $value = [];
+ for (@$n) {
+ unless (/^\d+$/) {
+ $self->warn(qq{"n" value "$_" is not a positive integer});
+ return;
+ }
+ push @$value, $values[$_ - 1]; # might be undef
+ }
+ }
+ elsif (!ref($n) && $n =~ /^\d+$/) {
+ $value = $values[$n - 1]; # might be undef
+ }
+ else {
+ $self->warn('"n" value is not a positive integer or an array ref');
+ return;
+ }
+ }
+ else {
+ $self->warn('Hash value is invalid');
+ return;
+ }
+ } # hashref
+
+ if (ref($value) eq 'ARRAY') {
+ $form->param($name, $value);
+ return 1;
+ }
+
+ $form->value($name => $value);
+ return 1;
+}
+
+=head2 $mech->set_fields( $name => $value ... )
+
+This method sets multiple fields of the current form. It takes a list
+of field name and value pairs. If there is more than one field with
+the same name, the first one found is set. If you want to select which
+of the duplicate field to set, use a value which is an anonymous array
+which has the field value and its number as the 2 elements.
+
+ # set the second foo field
+ $mech->set_fields( $name => [ 'foo', 2 ] );
+
+The fields are numbered from 1.
+
+This applies to the current form.
+
+=cut
+
+sub set_fields {
+ my $self = shift;
+ my %fields = @_;
+
+ my $form = $self->current_form or $self->die( 'No form defined' );
+
+ while ( my ( $field, $value ) = each %fields ) {
+ if ( ref $value eq 'ARRAY' ) {
+ $form->find_input( $field, undef,
+ $value->[1])->value($value->[0] );
+ }
+ else {
+ $form->value($field => $value);
+ }
+ } # while
+} # set_fields()
+
+=head2 $mech->set_visible( @criteria )
+
+This method sets fields of the current form without having to know
+their names. So if you have a login screen that wants a username and
+password, you do not have to fetch the form and inspect the source (or
+use the F<mech-dump> utility, installed with WWW::Mechanize) to see
+what the field names are; you can just say
+
+ $mech->set_visible( $username, $password );
+
+and the first and second fields will be set accordingly. The method
+is called set_I<visible> because it acts only on visible fields;
+hidden form inputs are not considered. The order of the fields is
+the order in which they appear in the HTML source which is nearly
+always the order anyone viewing the page would think they are in,
+but some creative work with tables could change that; caveat user.
+
+Each element in C<@criteria> is either a field value or a field
+specifier. A field value is a scalar. A field specifier allows
+you to specify the I<type> of input field you want to set and is
+denoted with an arrayref containing two elements. So you could
+specify the first radio button with
+
+ $mech->set_visible( [ radio => 'KCRW' ] );
+
+Field values and specifiers can be intermixed, hence
+
+ $mech->set_visible( 'fred', 'secret', [ option => 'Checking' ] );
+
+would set the first two fields to "fred" and "secret", and the I<next>
+C<OPTION> menu field to "Checking".
+
+The possible field specifier types are: "text", "password", "hidden",
+"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
+
+C<set_visible> returns the number of values set.
+
+=cut
+
+sub set_visible {
+ my $self = shift;
+
+ my $form = $self->current_form;
+ my @inputs = $form->inputs;
+
+ my $num_set = 0;
+ for my $value ( @_ ) {
+ # Handle type/value pairs an arrayref
+ if ( ref $value eq 'ARRAY' ) {
+ my ( $type, $value ) = @$value;
+ while ( my $input = shift @inputs ) {
+ next if $input->type eq 'hidden';
+ if ( $input->type eq $type ) {
+ $input->value( $value );
+ $num_set++;
+ last;
+ }
+ } # while
+ }
+ # by default, it's a value
+ else {
+ while ( my $input = shift @inputs ) {
+ next if $input->type eq 'hidden';
+ $input->value( $value );
+ $num_set++;
+ last;
+ } # while
+ }
+ } # for
+
+ return $num_set;
+} # set_visible()
+
+=head2 $mech->tick( $name, $value [, $set] )
+
+"Ticks" the first checkbox that has both the name and value associated
+with it on the current form. Dies if there is no named check box for
+that value. Passing in a false value as the third optional argument
+will cause the checkbox to be unticked.
+
+=cut
+
+sub tick {
+ my $self = shift;
+ my $name = shift;
+ my $value = shift;
+ my $set = @_ ? shift : 1; # default to 1 if not passed
+
+ # loop though all the inputs
+ my $index = 0;
+ while ( my $input = $self->current_form->find_input( $name, 'checkbox', $index ) ) {
+ # Can't guarantee that the first element will be undef and the second
+ # element will be the right name
+ foreach my $val ($input->possible_values()) {
+ next unless defined $val;
+ if ($val eq $value) {
+ $input->value($set ? $value : undef);
+ return;
+ }
+ }
+
+ # move onto the next input
+ $index++;
+ } # while
+
+ # got self far? Didn't find anything
+ $self->warn( qq{No checkbox "$name" for value "$value" in form} );
+} # tick()
+
+=head2 $mech->untick($name, $value)
+
+Causes the checkbox to be unticked. Shorthand for
+C<tick($name,$value,undef)>
+
+=cut
+
+sub untick {
+ shift->tick(shift,shift,undef);
+}
+
+=head2 $mech->value( $name [, $number] )
+
+Given the name of a field, return its value. This applies to the current
+form.
+
+The optional I<$number> parameter is used to distinguish between two fields
+with the same name. The fields are numbered from 1.
+
+If the field is of type file (file upload field), the value is always
+cleared to prevent remote sites from downloading your local files.
+To upload a file, specify its file name explicitly.
+
+=cut
+
+sub value {
+ my $self = shift;
+ my $name = shift;
+ my $number = shift || 1;
+
+ my $form = $self->current_form;
+ if ( $number > 1 ) {
+ return $form->find_input( $name, undef, $number )->value();
+ }
+ else {
+ return $form->value( $name );
+ }
+} # value
+
+=head2 $mech->click( $button [, $x, $y] )
+
+Has the effect of clicking a button on the current form. The first
+argument is the name of the button to be clicked. The second and
+third arguments (optional) allow you to specify the (x,y) coordinates
+of the click.
+
+If there is only one button on the form, C<< $mech->click() >> with
+no arguments simply clicks that one button.
+
+Returns an L<HTTP::Response> object.
+
+=cut
+
+sub click {
+ my ($self, $button, $x, $y) = @_;
+ for ($x, $y) { $_ = 1 unless defined; }
+ my $request = $self->current_form->click($button, $x, $y);
+ return $self->request( $request );
+}
+
+=head2 $mech->click_button( ... )
+
+Has the effect of clicking a button on the current form by specifying
+its name, value, or index. Its arguments are a list of key/value
+pairs. Only one of name, number, input or value must be specified in
+the keys.
+
+=over 4
+
+=item * C<< name => name >>
+
+Clicks the button named I<name> in the current form.
+
+=item * C<< number => n >>
+
+Clicks the I<n>th button in the current form. Numbering starts at 1.
+
+=item * C<< value => value >>
+
+Clicks the button with the value I<value> in the current form.
+
+=item * C<< input => $inputobject >>
+
+Clicks on the button referenced by $inputobject, an instance of
+L<HTML::Form::SubmitInput> obtained e.g. from
+
+ $mech->current_form()->find_input( undef, 'submit' )
+
+$inputobject must belong to the current form.
+
+=item * C<< x => x >>
+
+=item * C<< y => y >>
+
+These arguments (optional) allow you to specify the (x,y) coordinates
+of the click.
+
+=back
+
+=cut
+
+sub click_button {
+ my $self = shift;
+ my %args = @_;
+
+ for ( keys %args ) {
+ if ( !/^(number|name|value|input|x|y)$/ ) {
+ $self->warn( qq{Unknown click_button parameter "$_"} );
+ }
+ }
+
+ for ($args{x}, $args{y}) {
+ $_ = 1 unless defined;
+ }
+
+ my $form = $self->current_form or $self->die( 'click_button: No form has been selected' );
+
+ my $request;
+ if ( $args{name} ) {
+ $request = $form->click( $args{name}, $args{x}, $args{y} );
+ }
+ elsif ( $args{number} ) {
+ my $input = $form->find_input( undef, 'submit', $args{number} );
+ $request = $input->click( $form, $args{x}, $args{y} );
+ }
+ elsif ( $args{input} ) {
+ $request = $args{input}->click( $form, $args{x}, $args{y} );
+ }
+ elsif ( $args{value} ) {
+ my $i = 1;
+ while ( my $input = $form->find_input(undef, 'submit', $i) ) {
+ if ( $args{value} && ($args{value} eq $input->value) ) {
+ $request = $input->click( $form, $args{x}, $args{y} );
+ last;
+ }
+ $i++;
+ } # while
+ } # $args{value}
+
+ return $self->request( $request );
+}
+
+=head2 $mech->submit()
+
+Submits the page, without specifying a button to click. Actually,
+no button is clicked at all.
+
+Returns an L<HTTP::Response> object.
+
+This used to be a synonym for C<< $mech->click( 'submit' ) >>, but is no
+longer so.
+
+=cut
+
+sub submit {
+ my $self = shift;
+
+ my $request = $self->current_form->make_request;
+ return $self->request( $request );
+}
+
+=head2 $mech->submit_form( ... )
+
+This method lets you select a form from the previously fetched page,
+fill in its fields, and submit it. It combines the form_number/form_name,
+set_fields and click methods into one higher level call. Its arguments
+are a list of key/value pairs, all of which are optional.
+
+=over 4
+
+=item * C<< fields => \%fields >>
+
+Specifies the fields to be filled in the current form.
+
+=item * C<< with_fields => \%fields >>
+
+Probably all you need for the common case. It combines a smart form selector
+and data setting in one operation. It selects the first form that contains all
+fields mentioned in C<\%fields>. This is nice because you don't need to know
+the name or number of the form to do this.
+
+(calls C<L</form_with_fields()>> and C<L</set_fields()>>).
+
+If you choose this, the form_number, form_name, form_id and fields options will be ignored.
+
+=item * C<< form_number => n >>
+
+Selects the I<n>th form (calls C<L</form_number()>>). If this parm is not
+specified, the currently-selected form is used.
+
+=item * C<< form_name => name >>
+
+Selects the form named I<name> (calls C<L</form_name()>>)
+
+=item * C<< form_id => ID >>
+
+Selects the form with ID I<ID> (calls C<L</form_id()>>)
+
+=item * C<< button => button >>
+
+Clicks on button I<button> (calls C<L</click()>>)
+
+=item * C<< x => x, y => y >>
+
+Sets the x or y values for C<L</click()>>
+
+=back
+
+If no form is selected, the first form found is used.
+
+If I<button> is not passed, then the C<L</submit()>> method is used instead.
+
+If you want to submit a file and get its content from a scalar rather
+than a file in the filesystem, you can use:
+
+ $mech->submit_form(with_fields => { logfile => [ [ undef, 'whatever', Content => $content ], 1 ] } );
+
+Returns an L<HTTP::Response> object.
+
+=cut
+
+sub submit_form {
+ my( $self, %args ) = @_;
+
+ for ( keys %args ) {
+ if ( !/^(form_(number|name|fields|id)|(with_)?fields|button|x|y)$/ ) {
+ # XXX Why not die here?
+ $self->warn( qq{Unknown submit_form parameter "$_"} );
+ }
+ }
+
+ my $fields;
+ for (qw/with_fields fields/) {
+ if ($args{$_}) {
+ if ( ref $args{$_} eq 'HASH' ) {
+ $fields = $args{$_};
+ }
+ else {
+ die "$_ arg to submit_form must be a hashref";
+ }
+ last;
+ }
+ }
+
+ if ( $args{with_fields} ) {
+ $fields || die q{must submit some 'fields' with with_fields};
+ $self->form_with_fields(keys %{$fields}) or die "There is no form with the requested fields";
+ }
+ elsif ( my $form_number = $args{form_number} ) {
+ $self->form_number( $form_number ) or die "There is no form numbered $form_number";
+ }
+ elsif ( my $form_name = $args{form_name} ) {
+ $self->form_name( $form_name ) or die qq{There is no form named "$form_name"};
+ }
+ elsif ( my $form_id = $args{form_id} ) {
+ $self->form_id( $form_id ) or die qq{There is no form with ID "$form_id"};
+ }
+ else {
+ # No form selector was used.
+ # Maybe a form was set separately, or we'll default to the first form.
+ }
+
+ $self->set_fields( %{$fields} ) if $fields;
+
+ my $response;
+ if ( $args{button} ) {
+ $response = $self->click( $args{button}, $args{x} || 0, $args{y} || 0 );
+ }
+ else {
+ $response = $self->submit();
+ }
+
+ return $response;
+}
+
+=head1 MISCELLANEOUS METHODS
+
+=head2 $mech->add_header( name => $value [, name => $value... ] )
+
+Sets HTTP headers for the agent to add or remove from the HTTP request.
+
+ $mech->add_header( Encoding => 'text/klingon' );
+
+If a I<value> is C<undef>, then that header will be removed from any
+future requests. For example, to never send a Referer header:
+
+ $mech->add_header( Referer => undef );
+
+If you want to delete a header, use C<delete_header>.
+
+Returns the number of name/value pairs added.
+
+B<NOTE>: This method was very different in WWW::Mechanize before 1.00.
+Back then, the headers were stored in a package hash, not as a member of
+the object instance. Calling C<add_header()> would modify the headers
+for every WWW::Mechanize object, even after your object no longer existed.
+
+=cut
+
+sub add_header {
+ my $self = shift;
+ my $npairs = 0;
+
+ while ( @_ ) {
+ my $key = shift;
+ my $value = shift;
+ ++$npairs;
+
+ $self->{headers}{$key} = $value;
+ }
+
+ return $npairs;
+}
+
+=head2 $mech->delete_header( name [, name ... ] )
+
+Removes HTTP headers from the agent's list of special headers. For
+instance, you might need to do something like:
+
+ # Don't send a Referer for this URL
+ $mech->add_header( Referer => undef );
+
+ # Get the URL
+ $mech->get( $url );
+
+ # Back to the default behavior
+ $mech->delete_header( 'Referer' );
+
+=cut
+
+sub delete_header {
+ my $self = shift;
+
+ while ( @_ ) {
+ my $key = shift;
+
+ delete $self->{headers}{$key};
+ }
+
+ return;
+}
+
+
+=head2 $mech->quiet(true/false)
+
+Allows you to suppress warnings to the screen.
+
+ $mech->quiet(0); # turns on warnings (the default)
+ $mech->quiet(1); # turns off warnings
+ $mech->quiet(); # returns the current quietness status
+
+=cut
+
+sub quiet {
+ my $self = shift;
+
+ $self->{quiet} = $_[0] if @_;
+
+ return $self->{quiet};
+}
+
+=head2 $mech->stack_depth( $max_depth )
+
+Get or set the page stack depth. Use this if you're doing a lot of page
+scraping and running out of memory.
+
+A value of 0 means "no history at all." By default, the max stack depth
+is humongously large, effectively keeping all history.
+
+=cut
+
+sub stack_depth {
+ my $self = shift;
+ $self->{stack_depth} = shift if @_;
+ return $self->{stack_depth};
+}
+
+=head2 $mech->save_content( $filename )
+
+Dumps the contents of C<< $mech->content >> into I<$filename>.
+I<$filename> will be overwritten. Dies if there are any errors.
+
+If the content type does not begin with "text/", then the content
+is saved in binary mode.
+
+=cut
+
+sub save_content {
+ my $self = shift;
+ my $filename = shift;
+
+ open( my $fh, '>', $filename ) or $self->die( "Unable to create $filename: $!" );
+ binmode $fh unless $self->content_type =~ m{^text/};
+ print {$fh} $self->content or $self->die( "Unable to write to $filename: $!" );
+ close $fh or $self->die( "Unable to close $filename: $!" );
+
+ return;
+}
+
+
+=head2 $mech->dump_headers( [$fh] )
+
+Prints a dump of the HTTP response headers for the most recent
+response. If I<$fh> is not specified or is undef, it dumps to
+STDOUT.
+
+Unlike the rest of the dump_* methods, you cannot specify a filehandle
+to print to.
+
+=cut
+
+sub dump_headers {
+ my $self = shift;
+ my $fh = shift || \*STDOUT;
+
+ print {$fh} $self->response->headers_as_string;
+
+ return;
+}
+
+
+=head2 $mech->dump_links( [[$fh], $absolute] )
+
+Prints a dump of the links on the current page to I<$fh>. If I<$fh>
+is not specified or is undef, it dumps to STDOUT.
+
+If I<$absolute> is true, links displayed are absolute, not relative.
+
+=cut
+
+sub dump_links {
+ my $self = shift;
+ my $fh = shift || \*STDOUT;
+ my $absolute = shift;
+
+ for my $link ( $self->links ) {
+ my $url = $absolute ? $link->url_abs : $link->url;
+ $url = '' if not defined $url;
+ print {$fh} $url, "\n";
+ }
+ return;
+}
+
+=head2 $mech->dump_images( [[$fh], $absolute] )
+
+Prints a dump of the images on the current page to I<$fh>. If I<$fh>
+is not specified or is undef, it dumps to STDOUT.
+
+If I<$absolute> is true, links displayed are absolute, not relative.
+
+=cut
+
+sub dump_images {
+ my $self = shift;
+ my $fh = shift || \*STDOUT;
+ my $absolute = shift;
+
+ for my $image ( $self->images ) {
+ my $url = $absolute ? $image->url_abs : $image->url;
+ $url = '' if not defined $url;
+ print {$fh} $url, "\n";
+ }
+ return;
+}
+
+=head2 $mech->dump_forms( [$fh] )
+
+Prints a dump of the forms on the current page to I<$fh>. If I<$fh>
+is not specified or is undef, it dumps to STDOUT.
+
+=cut
+
+sub dump_forms {
+ my $self = shift;
+ my $fh = shift || \*STDOUT;
+
+ for my $form ( $self->forms ) {
+ print {$fh} $form->dump, "\n";
+ }
+ return;
+}
+
+=head2 $mech->dump_text( [$fh] )
+
+Prints a dump of the text on the current page to I<$fh>. If I<$fh>
+is not specified or is undef, it dumps to STDOUT.
+
+=cut
+
+sub dump_text {
+ my $self = shift;
+ my $fh = shift || \*STDOUT;
+ my $absolute = shift;
+
+ print {$fh} $self->text, "\n";
+
+ return;
+}
+
+
+=head1 OVERRIDDEN LWP::UserAgent METHODS
+
+=head2 $mech->clone()
+
+Clone the mech object. The clone will be using the same cookie jar
+as the original mech.
+
+=cut
+
+sub clone {
+ my $self = shift;
+ my $clone = $self->SUPER::clone();
+
+ $clone->cookie_jar( $self->cookie_jar );
+
+ return $clone;
+}
+
+
+=head2 $mech->redirect_ok()
+
+An overloaded version of C<redirect_ok()> in L<LWP::UserAgent>.
+This method is used to determine whether a redirection in the request
+should be followed.
+
+Note that WWW::Mechanize's constructor pushes POST on to the agent's
+C<requests_redirectable> list.
+
+=cut
+
+sub redirect_ok {
+ my $self = shift;
+ my $prospective_request = shift;
+ my $response = shift;
+
+ my $ok = $self->SUPER::redirect_ok( $prospective_request, $response );
+ if ( $ok ) {
+ $self->{redirected_uri} = $prospective_request->uri;
+ }
+
+ return $ok;
+}
+
+
+=head2 $mech->request( $request [, $arg [, $size]])
+
+Overloaded version of C<request()> in L<LWP::UserAgent>. Performs
+the actual request. Normally, if you're using WWW::Mechanize, it's
+because you don't want to deal with this level of stuff anyway.
+
+Note that C<$request> will be modified.
+
+Returns an L<HTTP::Response> object.
+
+=cut
+
+sub request {
+ my $self = shift;
+ my $request = shift;
+
+ $request = $self->_modify_request( $request );
+
+ if ( $request->method eq 'GET' || $request->method eq 'POST' ) {
+ $self->_push_page_stack();
+ }
+
+ return $self->_update_page($request, $self->_make_request( $request, @_ ));
+}
+
+=head2 $mech->update_html( $html )
+
+Allows you to replace the HTML that the mech has found. Updates the
+forms and links parse-trees that the mech uses internally.
+
+Say you have a page that you know has malformed output, and you want to
+update it so the links come out correctly:
+
+ my $html = $mech->content;
+ $html =~ s[</option>.{0,3}</td>][</option></select></td>]isg;
+ $mech->update_html( $html );
+
+This method is also used internally by the mech itself to update its
+own HTML content when loading a page. This means that if you would
+like to I<systematically> perform the above HTML substitution, you
+would overload I<update_html> in a subclass thusly:
+
+ package MyMech;
+ use base 'WWW::Mechanize';
+
+ sub update_html {
+ my ($self, $html) = @_;
+ $html =~ s[</option>.{0,3}</td>][</option></select></td>]isg;
+ $self->WWW::Mechanize::update_html( $html );
+ }
+
+If you do this, then the mech will use the tidied-up HTML instead of
+the original both when parsing for its own needs, and for returning to
+you through L</content>.
+
+Overloading this method is also the recommended way of implementing
+extra validation steps (e.g. link checkers) for every HTML page
+received. L</warn> and L</die> would then come in handy to signal
+validation errors.
+
+=cut
+
+sub update_html {
+ my $self = shift;
+ my $html = shift;
+
+ $self->_reset_page;
+ $self->{ct} = 'text/html';
+ $self->{content} = $html;
+
+ return;
+}
+
+=head2 $mech->credentials( $username, $password )
+
+Provide credentials to be used for HTTP Basic authentication for
+all sites and realms until further notice.
+
+The four argument form described in L<LWP::UserAgent> is still
+supported.
+
+=cut
+
+sub credentials {
+ my $self = shift;
+
+ # The lastest LWP::UserAgent also supports 2 arguments,
+ # in which case the first is host:port
+ if (@_ == 4 || (@_ == 2 && $_[0] =~ /:\d+$/)) {
+ return $self->SUPER::credentials(@_);
+ }
+
+ @_ == 2
+ or $self->die( 'Invalid # of args for overridden credentials()' );
+
+ return @$self{qw( __username __password )} = @_;
+}
+
+=head2 $mech->get_basic_credentials( $realm, $uri, $isproxy )
+
+Returns the credentials for the realm and URI.
+
+=cut
+
+sub get_basic_credentials {
+ my $self = shift;
+ my @cred = grep { defined } @$self{qw( __username __password )};
+ return @cred if @cred == 2;
+ return $self->SUPER::get_basic_credentials(@_);
+}
+
+=head2 $mech->clear_credentials()
+
+Remove any credentials set up with C<credentials()>.
+
+=cut
+
+sub clear_credentials {
+ my $self = shift;
+ delete @$self{qw( __username __password )};
+}
+
+=head1 INHERITED UNCHANGED LWP::UserAgent METHODS
+
+As a sublass of L<LWP::UserAgent>, WWW::Mechanize inherits all of
+L<LWP::UserAgent>'s methods. Many of which are overridden or
+extended. The following methods are inherited unchanged. View the
+L<LWP::UserAgent> documentation for their implementation descriptions.
+
+This is not meant to be an inclusive list. LWP::UA may have added
+others.
+
+=head2 $mech->head()
+
+Inherited from L<LWP::UserAgent>.
+
+=head2 $mech->post()
+
+Inherited from L<LWP::UserAgent>.
+
+=head2 $mech->mirror()
+
+Inherited from L<LWP::UserAgent>.
+
+=head2 $mech->simple_request()
+
+Inherited from L<LWP::UserAgent>.
+
+=head2 $mech->is_protocol_supported()
+
+Inherited from L<LWP::UserAgent>.
+
+=head2 $mech->prepare_request()
+
+Inherited from L<LWP::UserAgent>.
+
+=head2 $mech->progress()
+
+Inherited from L<LWP::UserAgent>.
+
+=head1 INTERNAL-ONLY METHODS
+
+These methods are only used internally. You probably don't need to
+know about them.
+
+=head2 $mech->_update_page($request, $response)
+
+Updates all internal variables in $mech as if $request was just
+performed, and returns $response. The page stack is B<not> altered by
+this method, it is up to caller (e.g. L</request>) to do that.
+
+=cut
+
+sub _update_page {
+ my ($self, $request, $res) = @_;
+
+ $self->{req} = $request;
+ $self->{redirected_uri} = $request->uri->as_string;
+
+ $self->{res} = $res;
+
+ $self->{status} = $res->code;
+ $self->{base} = $res->base;
+ $self->{ct} = $res->content_type || '';
+
+ if ( $res->is_success ) {
+ $self->{uri} = $self->{redirected_uri};
+ $self->{last_uri} = $self->{uri};
+ }
+
+ if ( $res->is_error ) {
+ if ( $self->{autocheck} ) {
+ $self->die( 'Error ', $request->method, 'ing ', $request->uri, ': ', $res->message );
+ }
+ }
+
+ $self->_reset_page;
+
+ # Try to decode the content. Undef will be returned if there's nothing to decompress.
+ # See docs in HTTP::Message for details. Do we need to expose the options there?
+ my $content = $res->decoded_content();
+ $content = $res->content if (not defined $content);
+
+ $content .= _taintedness();
+
+ if ($self->is_html) {
+ $self->update_html($content);
+ }
+ else {
+ $self->{content} = $content;
+ }
+
+ return $res;
+} # _update_page
+
+our $_taintbrush;
+
+# This is lifted wholesale from Test::Taint
+sub _taintedness {
+ return $_taintbrush if defined $_taintbrush;
+
+ # Somehow we need to get some taintedness into our $_taintbrush.
+ # Let's try the easy way first. Either of these should be
+ # tainted, unless somebody has untainted them, so this
+ # will almost always work on the first try.
+ # (Unless, of course, taint checking has been turned off!)
+ $_taintbrush = substr("$0$^X", 0, 0);
+ return $_taintbrush if _is_tainted( $_taintbrush );
+
+ # Let's try again. Maybe somebody cleaned those.
+ $_taintbrush = substr(join('', grep { defined } @ARGV, %ENV), 0, 0);
+ return $_taintbrush if _is_tainted( $_taintbrush );
+
+ # If those don't work, go try to open some file from some unsafe
+ # source and get data from them. That data is tainted.
+ # (Yes, even reading from /dev/null works!)
+ for my $filename ( qw(/dev/null / . ..), values %INC, $0, $^X ) {
+ if ( open my $fh, '<', $filename ) {
+ my $data;
+ if ( defined sysread $fh, $data, 1 ) {
+ $_taintbrush = substr( $data, 0, 0 );
+ last if _is_tainted( $_taintbrush );
+ }
+ }
+ }
+
+ # Sanity check
+ die "Our taintbrush should have zero length!" if length $_taintbrush;
+
+ return $_taintbrush;
+}
+
+sub _is_tainted {
+ no warnings qw(void uninitialized);
+
+ return !eval { join('', shift), kill 0; 1 };
+} # _is_tainted
+
+
+=head2 $mech->_modify_request( $req )
+
+Modifies a L<HTTP::Request> before the request is sent out,
+for both GET and POST requests.
+
+We add a C<Referer> header, as well as header to note that we can accept gzip
+encoded content, if L<Compress::Zlib> is installed.
+
+=cut
+
+sub _modify_request {
+ my $self = shift;
+ my $req = shift;
+
+ # add correct Accept-Encoding header to restore compliance with
+ # http://www.freesoft.org/CIE/RFC/2068/158.htm
+ # http://use.perl.org/~rhesa/journal/25952
+ if (not $req->header( 'Accept-Encoding' ) ) {
+ # "identity" means "please! unencoded content only!"
+ $req->header( 'Accept-Encoding', $HAS_ZLIB ? 'gzip' : 'identity' );
+ }
+
+ my $last = $self->{last_uri};
+ if ( $last ) {
+ $last = $last->as_string if ref($last);
+ $req->header( Referer => $last );
+ }
+ while ( my($key,$value) = each %{$self->{headers}} ) {
+ if ( defined $value ) {
+ $req->header( $key => $value );
+ }
+ else {
+ $req->remove_header( $key );
+ }
+ }
+
+ return $req;
+}
+
+
+=head2 $mech->_make_request()
+
+Convenience method to make it easier for subclasses like
+L<WWW::Mechanize::Cached> to intercept the request.
+
+=cut
+
+sub _make_request {
+ my $self = shift;
+ return $self->SUPER::request(@_);
+}
+
+=head2 $mech->_reset_page()
+
+Resets the internal fields that track page parsed stuff.
+
+=cut
+
+sub _reset_page {
+ my $self = shift;
+
+ $self->{links} = undef;
+ $self->{images} = undef;
+ $self->{forms} = undef;
+ $self->{current_form} = undef;
+ $self->{title} = undef;
+ $self->{text} = undef;
+
+ return;
+}
+
+=head2 $mech->_extract_links()
+
+Extracts links from the content of a webpage, and populates the C<{links}>
+property with L<WWW::Mechanize::Link> objects.
+
+=cut
+
+my %link_tags = (
+ a => 'href',
+ area => 'href',
+ frame => 'src',
+ iframe => 'src',
+ link => 'href',
+ meta => 'content',
+);
+
+sub _extract_links {
+ my $self = shift;
+
+
+ $self->{links} = [];
+ if ( defined $self->{content} ) {
+ my $parser = HTML::TokeParser->new(\$self->{content});
+ while ( my $token = $parser->get_tag( keys %link_tags ) ) {
+ my $link = $self->_link_from_token( $token, $parser );
+ push( @{$self->{links}}, $link ) if $link;
+ } # while
+ }
+
+ return;
+}
+
+
+my %image_tags = (
+ img => 'src',
+ input => 'src',
+);
+
+sub _extract_images {
+ my $self = shift;
+
+ $self->{images} = [];
+
+ if ( defined $self->{content} ) {
+ my $parser = HTML::TokeParser->new(\$self->{content});
+ while ( my $token = $parser->get_tag( keys %image_tags ) ) {
+ my $image = $self->_image_from_token( $token, $parser );
+ push( @{$self->{images}}, $image ) if $image;
+ } # while
+ }
+
+ return;
+}
+
+sub _image_from_token {
+ my $self = shift;
+ my $token = shift;
+ my $parser = shift;
+
+ my $tag = $token->[0];
+ my $attrs = $token->[1];
+
+ if ( $tag eq 'input' ) {
+ my $type = $attrs->{type} or return;
+ return unless $type eq 'image';
+ }
+
+ require WWW::Mechanize::Image;
+ return
+ WWW::Mechanize::Image->new({
+ tag => $tag,
+ base => $self->base,
+ url => $attrs->{src},
+ name => $attrs->{name},
+ height => $attrs->{height},
+ width => $attrs->{width},
+ alt => $attrs->{alt},
+ });
+}
+
+sub _link_from_token {
+ my $self = shift;
+ my $token = shift;
+ my $parser = shift;
+
+ my $tag = $token->[0];
+ my $attrs = $token->[1];
+ my $url = $attrs->{$link_tags{$tag}};
+
+ my $text;
+ my $name;
+ if ( $tag eq 'a' ) {
+ $text = $parser->get_trimmed_text("/$tag");
+ $text = '' unless defined $text;
+
+ my $onClick = $attrs->{onclick};
+ if ( $onClick && ($onClick =~ /^window\.open\(\s*'([^']+)'/) ) {
+ $url = $1;
+ }
+ } # a
+
+ # Of the tags we extract from, only 'AREA' has an alt tag
+ # The rest should have a 'name' attribute.
+ # ... but we don't do anything with that bit of wisdom now.
+
+ $name = $attrs->{name};
+
+ if ( $tag eq 'meta' ) {
+ my $equiv = $attrs->{'http-equiv'};
+ my $content = $attrs->{'content'};
+ return unless $equiv && (lc $equiv eq 'refresh') && defined $content;
+
+ if ( $content =~ /^\d+\s*;\s*url\s*=\s*(\S+)/i ) {
+ $url = $1;
+ $url =~ s/^"(.+)"$/$1/ or $url =~ s/^'(.+)'$/$1/;
+ }
+ else {
+ undef $url;
+ }
+ } # meta
+
+ return unless defined $url; # probably just a name link or <AREA NOHREF...>
+
+ require WWW::Mechanize::Link;
+ return
+ WWW::Mechanize::Link->new({
+ url => $url,
+ text => $text,
+ name => $name,
+ tag => $tag,
+ base => $self->base,
+ attrs => $attrs,
+ });
+} # _link_from_token
+
+
+sub _extract_forms {
+ my $self = shift;
+
+ my @forms = HTML::Form->parse( $self->content, $self->base );
+ $self->{forms} = \@forms;
+ for my $form ( @forms ) {
+ for my $input ($form->inputs) {
+ if ($input->type eq 'file') {
+ $input->value( undef );
+ }
+ }
+ }
+
+ return;
+}
+
+=head2 $mech->_push_page_stack()
+
+The agent keeps a stack of visited pages, which it can pop when it needs
+to go BACK and so on.
+
+The current page needs to be pushed onto the stack before we get a new
+page, and the stack needs to be popped when BACK occurs.
+
+Neither of these take any arguments, they just operate on the $mech
+object.
+
+=cut
+
+sub _push_page_stack {
+ my $self = shift;
+
+ my $req = $self->{req};
+ my $res = $self->{res};
+
+ return unless $req && $res && $self->stack_depth;
+
+ # Don't push anything if it's a virgin object
+ my $stack = $self->{page_stack} ||= [];
+ if ( @{$stack} >= $self->stack_depth ) {
+ shift @{$stack};
+ }
+ push( @{$stack}, { req => $req, res => $res } );
+
+ return 1;
+}
+
+=head2 warn( @messages )
+
+Centralized warning method, for diagnostics and non-fatal problems.
+Defaults to calling C<CORE::warn>, but may be overridden by setting
+C<onwarn> in the constructor.
+
+=cut
+
+sub warn {
+ my $self = shift;
+
+ return unless my $handler = $self->{onwarn};
+
+ return if $self->quiet;
+
+ return $handler->(@_);
+}
+
+=head2 die( @messages )
+
+Centralized error method. Defaults to calling C<CORE::die>, but
+may be overridden by setting C<onerror> in the constructor.
+
+=cut
+
+sub die {
+ my $self = shift;
+
+ return unless my $handler = $self->{onerror};
+
+ return $handler->(@_);
+}
+
+
+# NOT an object method!
+sub _warn {
+ require Carp;
+ return &Carp::carp; ## no critic
+}
+
+# NOT an object method!
+sub _die {
+ require Carp;
+ return &Carp::croak; ## no critic
+}
+
+1; # End of module
+
+__END__
+
+=head1 WWW::MECHANIZE'S GIT REPOSITORY
+
+WWW::Mechanize is hosted at GitHub, though the bug tracker still
+lives at Google Code.
+
+Repository: https://github.com/bestpractical/www-mechanize/.
+Bugs: http://code.google.com/p/www-mechanize/issues
+
+=head1 OTHER DOCUMENTATION
+
+=head2 I<Spidering Hacks>, by Kevin Hemenway and Tara Calishain
+
+I<Spidering Hacks> from O'Reilly
+(L<http://www.oreilly.com/catalog/spiderhks/>) is a great book for anyone
+wanting to know more about screen-scraping and spidering.
+
+There are six hacks that use Mech or a Mech derivative:
+
+=over 4
+
+=item #21 WWW::Mechanize 101
+
+=item #22 Scraping with WWW::Mechanize
+
+=item #36 Downloading Images from Webshots
+
+=item #44 Archiving Yahoo! Groups Messages with WWW::Yahoo::Groups
+
+=item #64 Super Author Searching
+
+=item #73 Scraping TV Listings
+
+=back
+
+The book was also positively reviewed on Slashdot:
+L<http://books.slashdot.org/article.pl?sid=03/12/11/2126256>
+
+=head1 ONLINE RESOURCES AND SUPPORT
+
+=over 4
+
+=item * WWW::Mechanize mailing list
+
+The Mech mailing list is at
+L<http://groups.google.com/group/www-mechanize-users> and is specific
+to Mechanize, unlike the LWP mailing list below. Although it is a
+users list, all development discussion takes place here, too.
+
+=item * LWP mailing list
+
+The LWP mailing list is at
+L<http://lists.perl.org/showlist.cgi?name=libwww>, and is more
+user-oriented and well-populated than the WWW::Mechanize list.
+
+=item * Perlmonks
+
+L<http://perlmonks.org> is an excellent community of support, and
+many questions about Mech have already been answered there.
+
+=item * L<WWW::Mechanize::Examples>
+
+A random array of examples submitted by users, included with the
+Mechanize distribution.
+
+=back
+
+=head1 ARTICLES ABOUT WWW::MECHANIZE
+
+=over 4
+
+=item * L<http://www-128.ibm.com/developerworks/linux/library/wa-perlsecure.html>
+
+IBM article "Secure Web site access with Perl"
+
+=item * L<http://www.oreilly.com/catalog/googlehks2/chapter/hack84.pdf>
+
+Leland Johnson's hack #84 in I<Google Hacks, 2nd Edition> is
+an example of a production script that uses WWW::Mechanize and
+HTML::TableContentParser. It takes in keywords and returns the estimated
+price of these keywords on Google's AdWords program.
+
+=item * L<http://www.perl.com/pub/a/2004/06/04/recorder.html>
+
+Linda Julien writes about using HTTP::Recorder to create WWW::Mechanize
+scripts.
+
+=item * L<http://www.developer.com/lang/other/article.php/3454041>
+
+Jason Gilmore's article on using WWW::Mechanize for scraping sales
+information from Amazon and eBay.
+
+=item * L<http://www.perl.com/pub/a/2003/01/22/mechanize.html>
+
+Chris Ball's article about using WWW::Mechanize for scraping TV
+listings.
+
+=item * L<http://www.stonehenge.com/merlyn/LinuxMag/col47.html>
+
+Randal Schwartz's article on scraping Yahoo News for images. It's
+already out of date: He manually walks the list of links hunting
+for matches, which wouldn't have been necessary if the C<find_link()>
+method existed at press time.
+
+=item * L<http://www.perladvent.org/2002/16th/>
+
+WWW::Mechanize on the Perl Advent Calendar, by Mark Fowler.
+
+=item * L<http://www.linux-magazin.de/Artikel/ausgabe/2004/03/perl/perl.html>
+
+Michael Schilli's article on Mech and L<WWW::Mechanize::Shell> for the
+German magazine I<Linux Magazin>.
+
+=back
+
+=head2 Other modules that use Mechanize
+
+Here are modules that use or subclass Mechanize. Let me know of any others:
+
+=over 4
+
+=item * L<Finance::Bank::LloydsTSB>
+
+=item * L<HTTP::Recorder>
+
+Acts as a proxy for web interaction, and then generates WWW::Mechanize scripts.
+
+=item * L<Win32::IE::Mechanize>
+
+Just like Mech, but using Microsoft Internet Explorer to do the work.
+
+=item * L<WWW::Bugzilla>
+
+=item * L<WWW::CheckSite>
+
+=item * L<WWW::Google::Groups>
+
+=item * L<WWW::Hotmail>
+
+=item * L<WWW::Mechanize::Cached>
+
+=item * L<WWW::Mechanize::FormFiller>
+
+=item * L<WWW::Mechanize::Shell>
+
+=item * L<WWW::Mechanize::Sleepy>
+
+=item * L<WWW::Mechanize::SpamCop>
+
+=item * L<WWW::Mechanize::Timed>
+
+=item * L<WWW::SourceForge>
+
+=item * L<WWW::Yahoo::Groups>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to the numerous people who have helped out on WWW::Mechanize in
+one way or another, including
+Kirrily Robert for the original C<WWW::Automate>,
+Lyle Hopkins,
+Damien Clark,
+Ansgar Burchardt,
+Gisle Aas,
+Jeremy Ary,
+Hilary Holz,
+Rafael Kitover,
+Norbert Buchmuller,
+Dave Page,
+David Sainty,
+H.Merijn Brand,
+Matt Lawrence,
+Michael Schwern,
+Adriano Ferreira,
+Miyagawa,
+Peteris Krumins,
+Rafael Kitover,
+David Steinbrunner,
+Kevin Falcone,
+Mike O'Regan,
+Mark Stosberg,
+Uri Guttman,
+Peter Scott,
+Phillipe Bruhat,
+Ian Langworth,
+John Beppu,
+Gavin Estey,
+Jim Brandt,
+Ask Bjoern Hansen,
+Greg Davies,
+Ed Silva,
+Mark-Jason Dominus,
+Autrijus Tang,
+Mark Fowler,
+Stuart Children,
+Max Maischein,
+Meng Wong,
+Prakash Kailasa,
+Abigail,
+Jan Pazdziora,
+Dominique Quatravaux,
+Scott Lanning,
+Rob Casey,
+Leland Johnson,
+Joshua Gatcomb,
+Julien Beasley,
+Abe Timmerman,
+Peter Stevens,
+Pete Krawczyk,
+Tad McClellan,
+and the late great Iain Truskett.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2010 Andy Lester. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=cut
--- /dev/null
+=head1 NAME
+
+WWW::Mechanize::Cookbook - Recipes for using WWW::Mechanize
+
+=head1 INTRODUCTION
+
+First, please note that many of these are possible just using
+L<LWP::UserAgent>. Since C<WWW::Mechanize> is a subclass of
+L<LWP::UserAgent>, whatever works on C<LWP::UserAgent> should work
+on C<WWW::Mechanize>. See the L<lwpcook> man page included with
+the L<libwww-perl> distribution.
+
+=head1 BASICS
+
+=head2 Launch the WWW::Mechanize browser
+
+ use WWW::Mechanize;
+
+ my $mech = WWW::Mechanize->new( autocheck => 1 );
+
+The C<< autocheck => 1 >> tells Mechanize to die if any IO fails,
+so you don't have to manually check. It's easier that way. If you
+want to do your own error checking, leave it out.
+
+=head2 Fetch a page
+
+ $mech->get( "http://search.cpan.org" );
+ print $mech->content;
+
+C<< $mech->content >> contains the raw HTML from the web page. It
+is not parsed or handled in any way, at least through the C<content>
+method.
+
+=head2 Fetch a page into a file
+
+Sometimes you want to dump your results directly into a file. For
+example, there's no reason to read a JPEG into memory if you're
+only going to write it out immediately. This can also help with
+memory issues on large files.
+
+ $mech->get( "http://www.cpan.org/src/stable.tar.gz",
+ ":content_file" => "stable.tar.gz" );
+
+=head2 Fetch a password-protected page
+
+Generally, just call C<credentials> before fetching the page.
+
+ $mech->credentials( 'admin' => 'password' );
+ $mech->get( 'http://10.11.12.13/password.html' );
+ print $mech->content();
+
+=head1 LINKS
+
+=head2 Find all image links
+
+Find all links that point to a JPEG, GIF or PNG.
+
+ my @links = $mech->find_all_links(
+ tag => "a", url_regex => qr/\.(jpe?g|gif|png)$/i );
+
+=head2 Find all download links
+
+Find all links that have the word "download" in them.
+
+ my @links = $mech->find_all_links(
+ tag => "a", text_regex => qr/\bdownload\b/i );
+
+=head1 APPLICATIONS
+
+=head2 Check all pages on a web site
+
+Use Abe Timmerman's L<WWW::CheckSite>
+L<http://search.cpan.org/dist/WWW-CheckSite/>
+
+=head1 SEE ALSO
+
+L<WWW::Mechanize>
+
+=head1 AUTHORS
+
+Copyright 2005-2010 Andy Lester C<< <andy@petdance.com> >>
+
+Later contributions by Peter Scott, Mark Stosberg and others. See
+Acknowledgements section in L<WWW::Mechanize> for more.
+
+=cut
--- /dev/null
+=head1 NAME
+
+WWW::Mechanize::Examples - Sample programs that use WWW::Mechanize
+
+=head1 SYNOPSIS
+
+Plenty of people have learned WWW::Mechanize, and now, you can too!
+
+Following are user-supplied samples of WWW::Mechanize in action.
+If you have samples you'd like to contribute, please send 'em to
+C<< <andy@petdance.com> >>.
+
+You can also look at the F<t/*.t> files in the distribution.
+
+Please note that these examples are not intended to do any specific task.
+For all I know, they're no longer functional because the sites they
+hit have changed. They're here to give examples of how people have
+used WWW::Mechanize.
+
+Note that the examples are in reverse order of my having received them,
+so the freshest examples are always at the top.
+
+=head2 Starbucks Density Calculator, by Nat Torkington
+
+Here's a pair of programs from Nat Torkington, editor for O'Reilly Media
+and co-author of the I<Perl Cookbook>.
+
+=over 4
+
+Rael [Dornfest] discovered that you can easily find out how many Starbucks
+there are in an area by searching for "Starbucks". So I wrote a silly
+scraper for some old census data and came up with some Starbucks density
+figures. There's no meaning to these numbers thanks to errors from using
+old census data coupled with false positives in Yahoo search (e.g.,
+"Dodie Starbuck-Your Style Desgn" in Portland OR). But it was fun to
+waste a night on.
+
+Here are the top twenty cities in descending order of population,
+with the amount of territory each Starbucks has. E.g., A New York NY
+Starbucks covers 1.7 square miles of ground.
+
+ New York, NY 1.7
+ Los Angeles, CA 1.2
+ Chicago, IL 1.0
+ Houston, TX 4.6
+ Philadelphia, PA 6.8
+ San Diego, CA 2.7
+ Detroit, MI 19.9
+ Dallas, TX 2.7
+ Phoenix, AZ 4.1
+ San Antonio, TX 12.3
+ San Jose, CA 1.1
+ Baltimore, MD 3.9
+ Indianapolis, IN 12.1
+ San Francisco, CA 0.5
+ Jacksonville, FL 39.9
+ Columbus, OH 7.3
+ Milwaukee, WI 5.1
+ Memphis, TN 15.1
+ Washington, DC 1.4
+ Boston, MA 0.5
+
+=back
+
+C<get_pop_data>
+
+ #!/usr/bin/perl -w
+
+ use WWW::Mechanize;
+ use Storable;
+
+ $url = 'http://www.census.gov/population/www/documentation/twps0027.html';
+ $m = WWW::Mechanize->new();
+ $m->get($url);
+
+ $c = $m->content;
+
+ $c =~ m{<A NAME=.tabA.>(.*?)</TABLE>}s
+ or die "Can't find the population table\n";
+ $t = $1;
+ @outer = $t =~ m{<TR.*?>(.*?)</TR>}gs;
+ shift @outer;
+ foreach $r (@outer) {
+ @bits = $r =~ m{<TD.*?>(.*?)</TD>}gs;
+ for ($x = 0; $x < @bits; $x++) {
+ $b = $bits[$x];
+ @v = split /\s*<BR>\s*/, $b;
+ foreach (@v) { s/^\s+//; s/\s+$// }
+ push @{$data[$x]}, @v;
+ }
+ }
+
+ for ($y = 0; $y < @{$data[0]}; $y++) {
+ $data{$data[1][$y]} = {
+ NAME => $data[1][$y],
+ RANK => $data[0][$y],
+ POP => comma_free($data[2][$y]),
+ AREA => comma_free($data[3][$y]),
+ DENS => comma_free($data[4][$y]),
+ };
+ }
+
+ store(\%data, "cities.dat");
+
+ sub comma_free {
+ my $n = shift;
+ $n =~ s/,//;
+ return $n;
+ }
+
+
+C<plague_of_coffee>
+
+ #!/usr/bin/perl -w
+
+ use WWW::Mechanize;
+ use strict;
+ use Storable;
+
+ $SIG{__WARN__} = sub {} ; # ssssssh
+
+ my $Cities = retrieve("cities.dat");
+
+ my $m = WWW::Mechanize->new();
+ $m->get("http://local.yahoo.com/");
+
+ my @cities = sort { $Cities->{$a}{RANK} <=> $Cities->{$b}{RANK} } keys %$Cities;
+ foreach my $c ( @cities ) {
+ my $fields = {
+ 'stx' => "starbucks",
+ 'csz' => $c,
+ };
+
+ my $r = $m->submit_form(form_number => 2,
+ fields => $fields);
+ die "Couldn't submit form" unless $r->is_success;
+
+ my $hits = number_of_hits($r);
+ # my $ppl = sprintf("%d", 1000 * $Cities->{$c}{POP} / $hits);
+ # print "$c has $hits Starbucks. That's one for every $ppl people.\n";
+ my $density = sprintf("%.1f", $Cities->{$c}{AREA} / $hits);
+ print "$c : $density\n";
+ }
+
+ sub number_of_hits {
+ my $r = shift;
+ my $c = $r->content;
+ if ($c =~ m{\d+ out of <b>(\d+)</b> total results for}) {
+ return $1;
+ }
+ if ($c =~ m{Sorry, no .*? found in or near}) {
+ return 0;
+ }
+ if ($c =~ m{Your search matched multiple cities}) {
+ warn "Your search matched multiple cities\n";
+ return 0;
+ }
+ if ($c =~ m{Sorry we couldn.t find that location}) {
+ warn "No cities\n";
+ return 0;
+ }
+ if ($c =~ m{Could not find.*?, showing results for}) {
+ warn "No matches\n";
+ return 0;
+ }
+ die "Unknown response\n$c\n";
+ }
+
+
+
+=head2 pb-upload, by John Beppu
+
+This program takes filenames of images from the command line and
+uploads them to a www.photobucket.com folder. John Beppu, the author, says:
+
+=over 4
+
+I had 92 pictures I wanted to upload, and doing it through a browser
+would've been torture. But thanks to mech, all I had to do was
+`./pb.upload *.jpg` and watch it do its thing. It felt good.
+If I had more time, I'd implement WWW::Photobucket on top of
+WWW::Mechanize.
+
+=back
+
+ #!/usr/bin/perl -w -T
+
+ use strict;
+ use WWW::Mechanize;
+
+ my $login = "login_name";
+ my $password = "password";
+ my $folder = "folder";
+
+ my $url = "http://img78.photobucket.com/albums/v281/$login/$folder/";
+
+ # login to your photobucket.com account
+ my $mech = WWW::Mechanize->new();
+ $mech->get($url);
+ $mech->submit_form(
+ form_number => 1,
+ fields => { password => $password },
+ );
+ die unless ($mech->success);
+
+ # upload image files specified on command line
+ foreach (@ARGV) {
+ print "$_\n";
+ $mech->form_number(2);
+ $mech->field('the_file[]' => $_);
+ $mech->submit();
+ }
+
+=head2 listmod, by Ian Langworth
+
+Ian Langworth contributes this little gem that will bring joy to
+beleagured mailing list admins. It discards spam messages through
+mailman's web interface.
+
+
+ #!/arch/unix/bin/perl
+ use strict;
+ use warnings;
+ #
+ # listmod - fast alternative to mailman list interface
+ #
+ # usage: listmod crew XXXXXXXX
+ #
+
+ die "usage: $0 <listname> <password>\n" unless @ARGV == 2;
+ my ($listname, $password) = @ARGV;
+
+ use CGI qw(unescape);
+
+ use WWW::Mechanize;
+ my $m = WWW::Mechanize->new( autocheck => 1 );
+
+ use Term::ReadLine;
+ my $term = Term::ReadLine->new($0);
+
+ # submit the form, get the cookie, go to the list admin page
+ $m->get("https://lists.ccs.neu.edu/bin/admindb/$listname");
+ $m->set_visible( $password );
+ $m->click;
+
+ # exit if nothing to do
+ print "There are no pending requests.\n" and exit
+ if $m->content =~ /There are no pending requests/;
+
+ # select the first form and examine its contents
+ $m->form_number(1);
+ my $f = $m->current_form or die "Couldn't get first form!\n";
+
+ # get me the base form element for each email item
+ my @items = map {m/^.+?-(.+)/} grep {m/senderbanp/} $f->param
+ or die "Couldn't get items in first form!\n";
+
+ # iterate through items, prompt user, commit actions
+ foreach my $item (@items) {
+
+ # show item info
+ my $sender = unescape($item);
+ my ($subject) = [$f->find_input("senderbanp-$item")->value_names]->[1]
+ =~ /Subject:\s+(.+?)\s+Size:/g;
+
+ # prompt user
+ my $choice = '';
+ while ( $choice !~ /^[DAX]$/ ) {
+ print "$sender\: '$subject'\n";
+ $choice = uc $term->readline("Action: defer/accept/discard [dax]: ");
+ print "\n\n";
+ }
+
+ # set button
+ $m->field("senderaction-$item" => {D=>0,A=>1,X=>3}->{$choice});
+ }
+
+ # submit actions
+ $m->click;
+
+=head2 ccdl, by Andy Lester
+
+Steve McConnell, author of the landmark I<Code Complete> has put
+up the chapters for the 2nd edition in PDF format on his website.
+I needed to download them to take to Kinko's to have printed. This
+little program did it for me.
+
+
+ #!/usr/bin/perl -w
+
+ use strict;
+ use WWW::Mechanize;
+
+ my $start = "http://www.stevemcconnell.com/cc2/cc.htm";
+
+ my $mech = WWW::Mechanize->new( autocheck => 1 );
+ $mech->get( $start );
+
+ my @links = $mech->find_all_links( url_regex => qr/\d+.+\.pdf$/ );
+
+ for my $link ( @links ) {
+ my $url = $link->url_abs;
+ my $filename = $url;
+ $filename =~ s[^.+/][];
+
+ print "Fetching $url";
+ $mech->get( $url, ':content_file' => $filename );
+
+ print " ", -s $filename, " bytes\n";
+ }
+
+=head2 quotes.pl, by Andy Lester
+
+This was a program that was going to get a hack in I<Spidering Hacks>,
+but got cut at the last minute, probably because it's against IMDB's TOS
+to scrape from it. I present it here as an example, not a suggestion
+that you break their TOS.
+
+Last I checked, it didn't work because their HTML didn't match, but it's
+still good as sample code.
+
+ #!/usr/bin/perl -w
+
+ use strict;
+
+ use WWW::Mechanize;
+ use Getopt::Long;
+ use Text::Wrap;
+
+ my $match = undef;
+ my $random = undef;
+ GetOptions(
+ "match=s" => \$match,
+ "random" => \$random,
+ ) or exit 1;
+
+ my $movie = shift @ARGV or die "Must specify a movie\n";
+
+ my $quotes_page = get_quotes_page( $movie );
+ my @quotes = extract_quotes( $quotes_page );
+
+ if ( $match ) {
+ $match = quotemeta($match);
+ @quotes = grep /$match/i, @quotes;
+ }
+
+ if ( $random ) {
+ print $quotes[rand @quotes];
+ }
+ else {
+ print join( "\n", @quotes );
+ }
+
+
+ sub get_quotes_page {
+ my $movie = shift;
+
+ my $mech = WWW::Mechanize->new;
+ $mech->get( "http://www.imdb.com/search" );
+ $mech->success or die "Can't get the search page";
+
+ $mech->submit_form(
+ form_number => 2,
+ fields => {
+ title => $movie,
+ restrict => "Movies only",
+ },
+ );
+
+ my @links = $mech->find_all_links( url_regex => qr[^/Title] )
+ or die "No matches for \"$movie\" were found.\n";
+
+ # Use the first link
+ my ( $url, $title ) = @{$links[0]};
+
+ warn "Checking $title...\n";
+
+ $mech->get( $url );
+ my $link = $mech->find_link( text_regex => qr/Memorable Quotes/i )
+ or die qq{"$title" has no quotes in IMDB!\n};
+
+ warn "Fetching quotes...\n\n";
+ $mech->get( $link->[0] );
+
+ return $mech->content;
+ }
+
+
+ sub extract_quotes {
+ my $page = shift;
+
+ # Nibble away at the unwanted HTML at the beginnning...
+ $page =~ s/.+Memorable Quotes//si;
+ $page =~ s/.+?(<a name)/$1/si;
+
+ # ... and the end of the page
+ $page =~ s/Browse titles in the movie quotes.+$//si;
+ $page =~ s/<p.+$//g;
+
+ # Quotes separated by an <HR> tag
+ my @quotes = split( /<hr.+?>/, $page );
+
+ for my $quote ( @quotes ) {
+ my @lines = split( /<br>/, $quote );
+ for ( @lines ) {
+ s/<[^>]+>//g; # Strip HTML tags
+ s/\s+/ /g; # Squash whitespace
+ s/^ //; # Strip leading space
+ s/ $//; # Strip trailing space
+ s/"/"/g; # Replace HTML entity quotes
+
+ # Word-wrap to fit in 72 columns
+ $Text::Wrap::columns = 72;
+ $_ = wrap( '', ' ', $_ );
+ }
+ $quote = join( "\n", @lines );
+ }
+
+ return @quotes;
+ }
+
+=head2 cpansearch.pl, by Ed Silva
+
+A quick little utility to search the CPAN and fire up a browser
+with a results page.
+
+ #!/usr/bin/perl
+
+ # turn on perl's safety features
+ use strict;
+ use warnings;
+
+ # work out the name of the module we're looking for
+ my $module_name = $ARGV[0]
+ or die "Must specify module name on command line";
+
+ # create a new browser
+ use WWW::Mechanize;
+ my $browser = WWW::Mechanize->new();
+
+ # tell it to get the main page
+ $browser->get("http://search.cpan.org/");
+
+ # okay, fill in the box with the name of the
+ # module we want to look up
+ $browser->form_number(1);
+ $browser->field("query", $module_name);
+ $browser->click();
+
+ # click on the link that matches the module name
+ $browser->follow_link( text_regex => $module_name );
+
+ my $url = $browser->uri;
+
+ # launch a browser...
+ system('galeon', $url);
+
+ exit(0);
+
+
+=head2 lj_friends.cgi, by Matt Cashner
+
+ #!/usr/bin/perl
+
+ # Provides an rss feed of a paid user's LiveJournal friends list
+ # Full entries, protected entries, etc.
+ # Add to your favorite rss reader as
+ # http://your.site.com/cgi-bin/lj_friends.cgi?user=USER&password=PASSWORD
+
+ use warnings;
+ use strict;
+
+ use WWW::Mechanize;
+ use CGI;
+
+ my $cgi = CGI->new();
+ my $form = $cgi->Vars;
+
+ my $agent = WWW::Mechanize->new();
+
+ $agent->get('http://www.livejournal.com/login.bml');
+ $agent->form_number('3');
+ $agent->field('user',$form->{user});
+ $agent->field('password',$form->{password});
+ $agent->submit();
+ $agent->get('http://www.livejournal.com/customview.cgi?user='.$form->{user}.'&styleid=225596&checkcookies=1');
+ print "Content-type: text/plain\n\n";
+ print $agent->content();
+
+=head2 Hacking Movable Type, by Dan Rinzel
+
+ use strict;
+ use WWW::Mechanize;
+
+ # a tool to automatically post entries to a moveable type weblog, and set arbitrary creation dates
+
+ my $mech = WWW::Mechanize->new();
+ my $entry;
+ $entry->{title} = "Test AutoEntry Title";
+ $entry->{btext} = "Test AutoEntry Body";
+ $entry->{date} = '2002-04-15 14:18:00';
+ my $start = qq|http://my.blog.site/mt.cgi|;
+
+ $mech->get($start);
+ $mech->field('username','und3f1n3d');
+ $mech->field('password','obscur3d');
+ $mech->submit(); # to get login cookie
+ $mech->get(qq|$start?__mode=view&_type=entry&blog_id=1|);
+ $mech->form_name('entry_form');
+ $mech->field('title',$entry->{title});
+ $mech->field('category_id',1); # adjust as needed
+ $mech->field('text',$entry->{btext});
+ $mech->field('status',2); # publish, or 1 = draft
+ $results = $mech->submit();
+
+ # if we're ok with this entry being datestamped "NOW" (no {date} in %entry)
+ # we're done. Otherwise, time to be tricksy
+ # MT returns a 302 redirect from this form. the redirect itself contains a <body onload=""> handler
+ # which takes the user to an editable version of the form where the create date can be edited
+ # MT date format of YYYY-MM-DD HH:MI:SS is the only one that won't error out
+
+ if ($entry->{date} && $entry->{date} =~ /^\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}:\d{2}/) {
+ # travel the redirect
+ $results = $mech->get($results->{_headers}->{location});
+ $results->{_content} =~ /<body onLoad="([^\"]+)"/is;
+ my $js = $1;
+ $js =~ /\'([^']+)\'/;
+ $results = $mech->get($start.$1);
+ $mech->form_name('entry_form');
+ $mech->field('created_on_manual',$entry->{date});
+ $mech->submit();
+ }
+
+=head2 get-despair, by Randal Schwartz
+
+Randal submitted this bot that walks the despair.com site sucking down
+all the pictures.
+
+ use strict;
+ $|++;
+
+ use WWW::Mechanize;
+ use File::Basename;
+
+ my $m = WWW::Mechanize->new;
+
+ $m->get("http://www.despair.com/indem.html");
+
+ my @top_links = @{$m->links};
+
+ for my $top_link_num (0..$#top_links) {
+ next unless $top_links[$top_link_num][0] =~ /^http:/;
+
+ $m->follow_link( n=>$top_link_num ) or die "can't follow $top_link_num";
+
+ print $m->uri, "\n";
+ for my $image (grep m{^http://store4}, map $_->[0], @{$m->links}) {
+ my $local = basename $image;
+ print " $image...", $m->mirror($image, $local)->message, "\n"
+ }
+
+ $m->back or die "can't go back";
+ }
--- /dev/null
+=head1 NAME
+
+WWW::Mechanize::FAQ - Frequently Asked Questions about WWW::Mechanize
+
+=head1 How to get help with WWW::Mechanize
+
+If your question isn't answered here in the FAQ, please turn to the
+communities at:
+
+=over
+
+=item * L<http://perlmonks.org>
+
+=item * The libwww-perl mailing list at L<http://lists.perl.org>
+
+=back
+
+=head1 JavaScript
+
+=head2 I have this web page that has JavaScript on it, and my Mech program doesn't work.
+
+That's because WWW::Mechanize doesn't operate on the JavaScript. It only
+understands the HTML parts of the page.
+
+=head2 I thought Mech was supposed to work like a web browser.
+
+It does pretty much, but it doesn't support JavaScript.
+
+I added some basic attempts at picking up URLs in C<window.open()>
+calls and return them in C<< $mech->links >>. They work sometimes.
+
+Since Javascript is completely visible to the client, it cannot be used
+to prevent a scraper from following links. But it can make life difficult. If
+you want to scrape specific pages, then a solution is always possible.
+
+One typical use of Javascript is to perform argument checking before
+posting to the server. The URL you want is probably just buried in the
+Javascript function. Do a regular expression match on
+C<< $mech->content() >>
+to find the link that you want and C<< $mech->get >> it directly (this
+assumes that you know what you are looking for in advance).
+
+In more difficult cases, the Javascript is used for URL mangling to
+satisfy the needs of some middleware. In this case you need to figure
+out what the Javascript is doing (why are these URLs always really
+long?). There is probably some function with one or more arguments which
+calculates the new URL. Step one: using your favorite browser, get the
+before and after URLs and save them to files. Edit each file, converting
+the the argument separators ('?', '&' or ';') into newlines. Now it is
+easy to use diff or comm to find out what Javascript did to the URL.
+Step 2 - find the function call which created the URL - you will need
+to parse and interpret its argument list. The Javascript Debugger in the
+Firebug extension for Firefox helps with the analysis. At this point, it is
+fairly trivial to write your own function which emulates the Javascript
+for the pages you want to process.
+
+Here's annother approach that answers the question, "It works in Firefox,
+but why not Mech?" Everything the web server knows about the client is
+present in the HTTP request. If two requests are identical, the results
+should be identical. So the real question is "What is different between
+the mech request and the Firefox request?"
+
+The Firefox extension "Tamper Data" is an effective tool for examining
+the headers of the requests to the server. Compare that with what LWP
+is sending. Once the two are identical, the action of the server should
+be the same as well.
+
+I say "should", because this is an oversimplification - some values
+are naturally unique, e.g. a SessionID, but if a SessionID is present,
+that is probably sufficient, even though the value will be different
+between the LWP request and the Firefox request. The server could use
+the session to store information which is troublesome, but that's not
+the first place to look (and highly unlikely to be relevant when you
+are requesting the login page of your site).
+
+Generally the problem is to be found in missing or incorrect POSTDATA
+arguments, Cookies, User-Agents, Accepts, etc. If you are using mech,
+then redirects and cookies should not be a problem, but are listed here
+for completeness. If you are missing headers, C<< $mech->add_header >>
+can be used to add the headers that you need.
+
+=head2 Which modules work like Mechanize and have JavaScript support?
+
+In no particular order: L<Gtk2::WebKit::Mechanize>, L<Win32::IE::Mechanize>,
+L<WWW::Mechanize::Firefox>, L<WWW::Scripter>, L<WWW::Selenium>
+
+=head1 How do I do X?
+
+=head2 Can I do [such-and-such] with WWW::Mechanize?
+
+If it's possible with LWP::UserAgent, then yes. WWW::Mechanize is
+a subclass of L<LWP::UserAgent>, so all the wondrous magic of that
+class is inherited.
+
+=head2 How do I use WWW::Mechanize through a proxy server?
+
+See the docs in L<LWP::UserAgent> on how to use the proxy. Short version:
+
+ $mech->proxy(['http', 'ftp'], 'http://proxy.example.com:8000/');
+
+or get the specs from the environment:
+
+ $mech->env_proxy();
+
+ # Environment set like so:
+ gopher_proxy=http://proxy.my.place/
+ wais_proxy=http://proxy.my.place/
+ no_proxy="localhost,my.domain"
+ export gopher_proxy wais_proxy no_proxy
+
+=head2 How can I see what fields are on the forms?
+
+Use the mech-dump utility, optionally installed with Mechanize.
+
+ $ mech-dump --forms http://search.cpan.org
+ Dumping forms
+ GET http://search.cpan.org/search
+ query=
+ mode=all (option) [*all|module|dist|author]
+ <NONAME>=CPAN Search (submit)
+
+=head2 How do I get Mech to handle authentication?
+
+ use MIME::Base64;
+
+ my $agent = WWW::Mechanize->new();
+ my @args = (
+ Authorization => "Basic " .
+ MIME::Base64::encode( USER . ':' . PASS )
+ );
+
+ $agent->credentials( ADDRESS, REALM, USER, PASS );
+ $agent->get( URL, @args );
+
+If you want to use the credentials for all future requests, you can
+also use the L<LWP::UserAgent> C<default_header()> method instead
+of the extra arguments to C<get()>
+
+ $mech->default_header(
+ Authorization => 'Basic ' . encode_base64( USER . ':' . PASSWORD ) );
+
+=head2 How can I get WWW::Mechanize to execute this JavaScript?
+
+You can't. JavaScript is entirely client-based, and WWW::Mechanize
+is a client that doesn't understand JavaScript. See the top part
+of this FAQ.
+
+=head2 How do I check a checkbox that doesn't have a value defined?
+
+Set it to to the value of "on".
+
+ $mech->field( my_checkbox => 'on' );
+
+=head2 How do I handle frames?
+
+You don't deal with them as frames, per se, but as links. Extract
+them with
+
+ my @frame_links = $mech->find_link( tag => "frame" );
+
+=head2 How do I get a list of HTTP headers and their values?
+
+All L<HTTP::Headers> methods work on a L<HTTP::Response> object which is
+returned by the I<get()>, I<reload()>, I<response()/res()>, I<click()>,
+I<submit_form()>, and I<request()> methods.
+
+ my $mech = WWW::Mechanize->new( autocheck => 1 );
+ $mech->get( 'http://my.site.com' );
+ my $res = $mech->response();
+ for my $key ( $response->header_field_names() ) {
+ print $key, " : ", $response->header( $key ), "\n";
+ }
+
+=head2 How do I enable keep-alive?
+
+Since L<WWW::Mechanize> is a subclass of L<LWP::UserAgent>, you can
+use the same mechanism to enable keep-alive:
+
+ use LWP::ConnCache;
+ ...
+ $mech->conn_cache(LWP::ConnCache->new);
+
+=head2 How can I change/specify the action parameter of an HTML form?
+
+You can access the action of the form by utilizing the L<HTML::Form>
+object returned from one of the specifying form methods.
+
+Using C<< $mech->form_number($number) >>:
+
+ my $mech = WWW::mechanize->new;
+ $mech->get('http://someurlhere.com');
+ # Access the form using its Zero-Based Index by DOM order
+ $mech->form_number(0)->action('http://newAction'); #ABS URL
+
+Using C<< $mech->form_name($number) >>:
+
+ my $mech = WWW::mechanize->new;
+ $mech->get('http://someurlhere.com');
+ #Access the form using its Zero-Based Index by DOM order
+ $mech->form_name('trgForm')->action('http://newAction'); #ABS URL
+
+=head2 How do I save an image? How do I save a large tarball?
+
+An image is just content. You get the image and save it.
+
+ $mech->get( 'photo.jpg' );
+ $mech->save_content( '/path/to/my/directory/photo.jpg' );
+
+You can also save any content directly to disk using the C<:content_file>
+flag to C<get()>, which is part of L<LWP::UserAgent>.
+
+ $mech->get( 'http://www.cpan.org/src/stable.tar.gz',
+ ':content_file' => 'stable.tar.gz' );
+
+=head2 How do I pick a specific value from a C<< <select> >> list?
+
+Find the C<HTML::Form::ListInput> in the page.
+
+ my ($listbox) = $mech->find_all_inputs( name => 'listbox' );
+
+Then create a hash for the lookup:
+
+ my %name_lookup;
+ @name_lookup{ $listbox->value_names } = $listbox->possible_values;
+ my $value = $name_lookup{ 'Name I want' };
+
+If you have duplicate names, this method won't work, and you'll
+have to loop over C<< $listbox->value_names >> and
+C<< $listbox->possible_values >> in parallel until you find a
+matching name.
+
+=head2 How do I get Mech to not follow redirects?
+
+You use functionality in LWP::UserAgent, not Mech itself.
+
+ $mech->requests_redirectable( [] );
+
+Or you can set C<max_redirect>:
+
+ $mech->max_redirect( 0 );
+
+Both these options can also be set in the constructor. Mech doesn't
+understand them, so will pass them through to the LWP::UserAgent
+constructor.
+
+
+=head1 Why doesn't this work: Debugging your Mechanize program
+
+=head2 My Mech program doesn't work, but it works in the browser.
+
+Mechanize acts like a browser, but apparently something you're doing
+is not matching the browser's behavior. Maybe it's expecting a
+certain web client, or maybe you've not handling a field properly.
+For some reason, your Mech problem isn't doing exactly what the
+browser is doing, and when you find that, you'll have the answer.
+
+=head2 My Mech program gets these 500 errors.
+
+A 500 error from the web server says that the program on the server
+side died. Probably the web server program was expecting certain
+inputs that you didn't supply, and instead of handling it nicely,
+the program died.
+
+Whatever the cause of the 500 error, if it works in the browser,
+but not in your Mech program, you're not acting like the browser.
+See the previous question.
+
+=head2 Why doesn't my program handle this form correctly?
+
+Run F<mech-dump> on your page and see what it says.
+
+F<mech-dump> is a marvelous diagnostic tool for figuring out what forms
+and fields are on the page. Say you're scraping CNN.com, you'd get this:
+
+ $ mech-dump http://www.cnn.com/
+ GET http://search.cnn.com/cnn/search
+ source=cnn (hidden readonly)
+ invocationType=search/top (hidden readonly)
+ sites=web (radio) [*web/The Web ??|cnn/CNN.com ??]
+ query= (text)
+ <NONAME>=Search (submit)
+
+ POST http://cgi.money.cnn.com/servlets/quote_redirect
+ query= (text)
+ <NONAME>=GET (submit)
+
+ POST http://polls.cnn.com/poll
+ poll_id=2112 (hidden readonly)
+ question_1=<UNDEF> (radio) [1/Simplistic option|2/VIEW RESULTS]
+ <NONAME>=VOTE (submit)
+
+ GET http://search.cnn.com/cnn/search
+ source=cnn (hidden readonly)
+ invocationType=search/bottom (hidden readonly)
+ sites=web (radio) [*web/??CNN.com|cnn/??]
+ query= (text)
+ <NONAME>=Search (submit)
+
+Four forms, including the first one duplicated at the end. All the
+fields, all their defaults, lovingly generated by HTML::Form's C<dump>
+method.
+
+If you want to run F<mech-dump> on something that doesn't lend itself
+to a quick URL fetch, then use the C<save_content()> method to write
+the HTML to a file, and run F<mech-dump> on the file.
+
+=head2 Why don't https:// URLs work?
+
+You need either L<IO::Socket::SSL> or L<Crypt::SSLeay> installed.
+
+=head2 Why do I get "Input 'fieldname' is readonly"?
+
+You're trying to change the value of a hidden field and you have
+warnings on.
+
+First, make sure that you actually mean to change the field that you're
+changing, and that you don't have a typo. Usually, hidden variables are
+set by the site you're working on for a reason. If you change the value,
+you might be breaking some functionality by faking it out.
+
+If you really do want to change a hidden value, make the changes in a
+scope that has warnings turned off:
+
+ {
+ local $^W = 0;
+ $agent->field( name => $value );
+ }
+
+=head2 I tried to [such-and-such] and I got this weird error.
+
+Are you checking your errors?
+
+Are you sure?
+
+Are you checking that your action succeeded after every action?
+
+Are you sure?
+
+For example, if you try this:
+
+ $mech->get( "http://my.site.com" );
+ $mech->follow_link( "foo" );
+
+and the C<get> call fails for some reason, then the Mech internals
+will be unusable for the C<follow_link> and you'll get a weird
+error. You B<must>, after every action that GETs or POSTs a page,
+check that Mech succeeded, or all bets are off.
+
+ $mech->get( "http://my.site.com" );
+ die "Can't even get the home page: ", $mech->response->status_line
+ unless $mech->success;
+
+ $mech->follow_link( "foo" );
+ die "Foo link failed: ", $mech->response->status_line
+ unless $mech->success;
+
+=head2 How do I figure out why C<< $mech->get($url) >> doesn't work?
+
+There are many reasons why a C<< get() >> can fail. The server can take
+you to someplace you didn't expect. It can generate redirects which are
+not properly handled. You can get time-outs. Servers are down more often
+than you think! etc, etc, etc. A couple of places to start:
+
+=over 4
+
+=item 1 Check C<< $mech->status() >> after each call
+
+=item 2 Check the URL with C<< $mech->uri() >> to see where you ended up
+
+=item 3 Try debugging with C<< LWP::Debug >>.
+
+=back
+
+If things are really strange, turn on debugging with
+C<< use LWP::Debug qw(+); >>
+Just put this in the main program. This causes LWP to print out a trace
+of the HTTP traffic between client and server and can be used to figure
+out what is happening at the protocol level.
+
+It is also useful to set many traps to verify that processing is
+proceeding as expected. A Mech program should always have an "I didn't
+expect to get here" or "I don't recognize the page that I am processing"
+case and bail out.
+
+Since errors can be transient, by the time you notice that the error
+has occurred, it might not be possible to reproduce it manually. So
+for automated processing it is useful to email yourself the following
+information:
+
+=over 4
+
+=item * where processing is taking place
+
+=item * An Error Message
+
+=item * $mech->uri
+
+=item * $mech->content
+
+=back
+
+You can also save the content of the page with C<< $mech->save_content( 'filename.html' ); >>
+
+=head2 I submitted a form, but the server ignored everything! I got an empty form back!
+
+The post is handled by application software. It is common for PHP
+programmers to use the same file both to display a form and to process
+the arguments returned. So the first task of the application programmer
+is to decide whether there are arguments to processes. The program can
+check whether a particular parameter has been set, whether a hidden
+parameter has been set, or whether the submit button has been clicked.
+(There are probably other ways that I haven't thought of).
+
+In any case, if your form is not setting the parameter (e.g. the submit
+button) which the web application is keying on (and as an outsider there
+is no way to know what it is keying on), it will not notice that the form
+has been submitted. Try using C<< $mech->click() >> instead of
+C<< $mech->submit() >> or vice-versa.
+
+=head2 I've logged in to the server, but I get 500 errors when I try to get to protected content.
+
+Some web sites use distributed databases for their processing. It
+can take a few seconds for the login/session information to percolate
+through to all the servers. For human users with their slow reaction
+times, this is not a problem, but a Perl script can outrun the server.
+So try adding a C<sleep(5)> between logging in and actually doing anything
+(the optimal delay must be determined experimentally).
+
+=head2 Mech is a big memory pig! I'm running out of RAM!
+
+Mech keeps a history of every page, and the state it was in. It actually
+keeps a clone of the full Mech object at every step along the way.
+
+You can limit this stack size with the C<stack_depth> parm in the C<new()>
+constructor. If you set stack_size to 0, Mech will not keep any history.
+
+=head1 AUTHOR
+
+Copyright 2005-2009 Andy Lester C<< <andy at petdance.com> >>
+
+=cut
--- /dev/null
+package WWW::Mechanize::Image;
+# vi:et:sw=4 ts=4
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+WWW::Mechanize::Image - Image object for WWW::Mechanize
+
+=head1 SYNOPSIS
+
+Image object to encapsulate all the stuff that Mech needs
+
+=head1 Constructor
+
+=head2 new()
+
+Creates and returns a new C<WWW::Mechanize::Image> object.
+
+ my $image = WWW::Mechanize::Image->new( {
+ url => $url,
+ base => $base,
+ tag => $tag,
+ name => $name, # From the INPUT tag
+ height => $height, # optional
+ width => $width, # optional
+ alt => $alt, # optional
+ } );
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $parms = shift || {};
+
+ my $self = bless {}, $class;
+
+ for my $parm ( qw( url base tag height width alt name ) ) {
+ # Check for what we passed in, not whether it's defined
+ $self->{$parm} = $parms->{$parm} if exists $parms->{$parm};
+ }
+
+ # url and tag are always required
+ for ( qw( url tag ) ) {
+ exists $self->{$_} or die "WWW::Mechanize::Image->new must have a $_ argument";
+ }
+
+ return $self;
+}
+
+=head1 Accessors
+
+=head2 $link->url()
+
+URL from the link
+
+=head2 $link->base()
+
+Base URL to which the links are relative.
+
+=head2 $link->name()
+
+Name for the field from the NAME attribute, if any.
+
+=head2 $link->tag()
+
+Tag name (either "image" or "input")
+
+=head2 $link->height()
+
+Image height
+
+=head2 $link->width()
+
+Image width
+
+=head2 $link->alt()
+
+ALT attribute from the source tag, if any.
+
+=cut
+
+sub url { return ($_[0])->{url}; }
+sub base { return ($_[0])->{base}; }
+sub name { return ($_[0])->{name}; }
+sub tag { return ($_[0])->{tag}; }
+sub height { return ($_[0])->{height}; }
+sub width { return ($_[0])->{width}; }
+sub alt { return ($_[0])->{alt}; }
+
+=head2 $link->URI()
+
+Returns the URL as a L<URI::URL> object.
+
+=cut
+
+sub URI {
+ my $self = shift;
+
+ require URI::URL;
+ my $URI = URI::URL->new( $self->url, $self->base );
+
+ return $URI;
+}
+
+=head2 $link->url_abs()
+
+Returns the URL as an absolute URL string.
+
+=cut
+
+sub url_abs {
+ my $self = shift;
+
+ return $self->URI->abs;
+}
+
+=head1 SEE ALSO
+
+L<WWW::Mechanize> and L<WWW::Mechanize::Link>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2004-2010 Andy Lester.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of either:
+
+=over 4
+
+=item * the GNU General Public License as published by the Free
+Software Foundation; either version 1, or (at your option) any later
+version, or
+
+=item * the Artistic License version 2.0.
+
+=back
+
+=cut
+
+1;
--- /dev/null
+package WWW::Mechanize::Link;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+WWW::Mechanize::Link - Link object for WWW::Mechanize
+
+=head1 SYNOPSIS
+
+Link object to encapsulate all the stuff that Mech needs but nobody
+wants to deal with as an array.
+
+=head1 Constructor
+
+=head2 new()
+
+ my $link = WWW::Mechanize::Link->new( {
+ url => $url,
+ text => $text,
+ name => $name,
+ tag => $tag,
+ base => $base,
+ attr => $attr_href,
+ } );
+
+For compatibility, this older interface is also supported:
+
+ new( $url, $text, $name, $tag, $base, $attr_href )
+
+Creates and returns a new C<WWW::Mechanize::Link> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ my $self;
+
+ # The order of the first four must stay as they are for
+ # compatibility with older code.
+ if ( ref $_[0] eq 'HASH' ) {
+ $self = [ @{$_[0]}{ qw( url text name tag base attrs ) } ];
+ }
+ else {
+ $self = [ @_ ];
+ }
+
+ return bless $self, $class;
+}
+
+=head1 Accessors
+
+=head2 $link->url()
+
+URL from the link
+
+=head2 $link->text()
+
+Text of the link
+
+=head2 $link->name()
+
+NAME attribute from the source tag, if any.
+
+=head2 $link->tag()
+
+Tag name (one of: "a", "area", "frame", "iframe" or "meta").
+
+=head2 $link->base()
+
+Base URL to which the links are relative.
+
+=head2 $link->attrs()
+
+Returns hash ref of all the attributes and attribute values in the tag.
+
+=cut
+
+sub url { return ($_[0])->[0]; }
+sub text { return ($_[0])->[1]; }
+sub name { return ($_[0])->[2]; }
+sub tag { return ($_[0])->[3]; }
+sub base { return ($_[0])->[4]; }
+sub attrs { return ($_[0])->[5]; }
+
+=head2 $link->URI()
+
+Returns the URL as a L<URI::URL> object.
+
+=cut
+
+sub URI {
+ my $self = shift;
+
+ require URI::URL;
+ my $URI = URI::URL->new( $self->url, $self->base );
+
+ return $URI;
+}
+
+=head2 $link->url_abs()
+
+Returns a L<URI::URL> object for the absolute form of the string.
+
+=cut
+
+sub url_abs {
+ my $self = shift;
+
+ return $self->URI->abs;
+}
+
+=head1 SEE ALSO
+
+L<WWW::Mechanize> and L<WWW::Mechanize::Image>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2004-2010 Andy Lester.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of either:
+
+=over 4
+
+=item * the GNU General Public License as published by the Free
+Software Foundation; either version 1, or (at your option) any later
+version, or
+
+=item * the Artistic License version 2.0.
+
+=back
+
+=cut
+
+# vi:et:sw=4 ts=4
+
+1;
--- /dev/null
+The majority of this code is written from scratch for
+SurrealServices/SrSv, however some modules from CPAN have been imported
+into our tree, and/or modified for our use.
+
+SurrealServices has the following copyrights:
+
+Copyright tabris@surrealchat.net (tabris@tabris.net) 2004, 2005, 2006, 2007, 2008, 2009, 2010
+Copyright saturn@surrealchat.net 2004, 2005, 2006, 2007, 2008, 2009
+Copyright errietta@hotmail.com 2008
+Copyright musashix90@gmail.com 2009, 2010
+
+We do not claim ownership of the following modules which we have
+imported into our tree:
+
+Digest::SHA::PurePerl
+
+Crypt::SaltedHash is no longer in this project, its code has been
+replaced.
+
+Date::Parse
--- /dev/null
+You will need to have all of these installed:
+
+* Perl 5.8 and standard modules. (threads no longer required)
+ NOTE: Many linux distros place Perl's standard modules in a separate
+ package from Perl itself.
+* MySQL 5.0 or 5.1. 5.2 is not well tested; 5.3 and up are not
+supported.
+* Event module from CPAN
+* Date::Parse module from CPAN
+Both the Event and Date::Parse modules should be available
+in your favourite distro.
+
+1. Create a MySQL database and user for services to use. Ask
+your system administrator or see the MySQL manual for instructions.
+
+2. Make sure your IRCd is configured correctly.
+
+3. Type: cp -a config-example config
+Then edit the config files for your network.
+
+4. Type: ./db-setup.pl
+
+5. Type: ./services.pl
+
+6. Register your nick, then type: ./addroot.pl <yournick>
--- /dev/null
+This code is Copyright saturn@surrealchat.net and tabris@surrealchat.net
+
+© 2004-2006 saturn@surrealchat.net and tabris@surrealchat.net
+
+Terms are as in COPYING
+
--- /dev/null
+ SurrealServices is a full replacement for services like
+Auspice or Anope, offering NickServ, ChanServ, MemoServ,
+BotServ, OperServ. But it is more than that, it also has a
+plugin/module system akin to NeoStats. Additionally it is
+multithreaded to eliminate the problems with timers not expiring
+properly as well as not block everything on a complex or slow
+database query.
+
+You can contact us on irc.surrealchat.net #dev.lounge or via email:
+tabris@surrealchat.net or saturn@surrealchat.net
+
+-----------------------------------------------------------------------
+CONFIGURATION TIPS
+
+SrSv does not support ziplinks nor SSL, so it should be hosted on the
+same box as the hub, or at least the same local network.
+
+-----------------------------------------------------------------------
+NUMBER OF PROCESSES
+
+We recommend that you leave the "procs" setting at 4 for
+uniprocessor and dual processor servers. Our benchmarks have
+shown that increasing it above 4 does not provide any benefit.
+
+You may set "procs" to 0 for use on shell servers with a
+limit on the number of background processes. Be aware that
+certain SecurityBot features may cause unacceptable lag when
+running in single-process mode. This issue will be fixed in a
+future release.
+
+-----------------------------------------------------------------------
+MODULE CONFIGURATION
+
+"country" must be loaded AFTER services, and requires that you run
+country-table.pl before using it.
+
+We recommend you run country-table.pl daily in crontab.
+
+"geoip" is like country, but:
+a) a much larger set of tables.
+b) should not be loaded with country.
+c) requires utils/geoip.pl to be run at least once.
+d) Don't bother running geoip.pl more often than monthly in a crontab.
+e) the datafiles are generally updated on the first of the month
+f) geoip uses GeoLite City from MaxMind. We do not grant you a license to use it
+ and are not responsible for any consequences of your using it.
+
--- /dev/null
+ SrSv nee SurrealServices is currently being developed
+with UnrealIRCd 3.2.x in mind. As such many assumptions may be
+in place even if we did not intend there to be. This will
+probably make porting difficult, if not impossible. We, the
+coders, would like to apologize in advance for this fact.
+
+ This is an unfortunate consequence of only having
+UnrealIRCd at our immediate disposal. We would welcome patches
+to clean up such difficulties, as long as they remain
+sufficiently clean/readable and do not introduce assumptions
+incompatible with other ircds that SrSv is attempting to work
+with.
+
+ Among the assumptions to be noted are that all of your
+ircds are properly configured and that the configurations are
+uniform throughout your irc-network. We believe that this is a
+necessary aspect of a properly maintained network, and as such
+should not be an undue burden.
+
+ Definition of 'unsyncserver': This means a server that is
+not 100% conformant to the UnrealIRCd Server Protocol. Basically
+most services servers (NeoStats, denora, janus, etc) don't send an
+EOS at the end of their netburst. It seems that Unreal is perfectly
+happy with this, but SrSv isn't. When we don't receive an
+End-of-Sync message, we don't know if they're done announcing
+everything, and thus whether to start re-mangling channel modes.
+
+ Further of note is that SrSv does not have a full
+capability list for ircds and such may be necessary for
+portability (if your ircd does not support things like WATCH,
+SILENCE, etc).
+
+ IRC Networks known to be using SrSv as of this date
+(20100506):
+ irc.surrealchat.net (duh)
+ irc.CrystalNET.eu
+ irc.lucidchat.net
+ irc.pokebeach.com
+
+ We would appreciate any success reports from other networks,
+contact us on irc.surrealchat.net #dev.lounge or via email:
+tabris@surrealchat.net or saturn@surrealchat.net
--- /dev/null
+ SQLserv is a bot intended to make direct query of the database
+possible. It is not considered 'stable', and it barely works at all
+right now.
+
+ First, this service is potentially dangerous. At present only
+read-only commands are possible, but it is capable of being extended to
+allow modification of the database. Doing so without knowledge of the
+workings of the program may BREAK the program. If you do so you get to
+keep all the pieces. The coders of this module cannot be held
+responsible for what you do with it.
+
+ Second, at present it requires the 'services' module to be
+loaded, and the user to have ROOT access. This is for your protection.
+Modifying this module to allow regular opers to use this module MAY
+BREAK the app, and/or expose them to information that they are otherwise
+not supposed to have. Again, the coders of this module cannot be held
+responsible for what you do with it.
+
+ Third, this module does not protect you from doing invalid
+queries. This module does not prevent you from doing queries that may
+take 5 minutes to complete. Since the module has to run everything in
+the parent process, this may BREAK YOUR APP. As usual, we are not
+responsible for what you do with it.
+ADDENDUM: SQL queries are no longer executed in the parent, but the
+disclaimer still applies.
+
+ Fourth, there is no documentation for this module, not that much
+is necessary. You submit SQL queries to it, as if you were using the
+MySQL shell. It attempts to present the result back to you, much as the
+MySQL shell would. Embedded newlines in the returned data MAY BREAK. Not
+that there should be many cases of this in this program. You cannot run
+dependent queries (LOCK first, then SELECT, then UNLOCK), you cannot
+instantiate TEMPORARY tables. You cannot start a transaction. One-shot
+queries are all that is safe.
--- /dev/null
+SecurityBot is an all-purpose Security Maintenance System.
+
+It has TOR banning, DroneBL-Blacklist Banning, TKL (G:line and GZ:line)
+management, and a couple other more random features.
+
+The use of this system is at this time quite finicky, and is not
+recommended unless you have read through the SecurityBot code or talked
+to the coders. It was written for use on SurrealChat.net, and may not
+meet the 'ease of use' standard of the rest of SurrealServices.
+
+- TOR is more or less easy to use, just enable it in the config, and it
+should work.
+
+- DroneBL support requires permission from dronebl.org to
+download a copy of their blacklist.
+
+Enabling this option and not running the scripts/setting up the
+table will cause runtime errors. So don't do that. This is no
+different from the country system.
+
+- TKL handling is very similar to /stats G on Unreal, with some slight
+changes. The full documentation is available via
+
+/msg SecurityBot help TKL
--- /dev/null
+ SpamServ is a module written to watch channels for on-join private
+messages, which might be an indication of a spam bot. This module is not
+considered to be stable, and does not take any action for private messages
+received, only reports the private messages to the diagnostics channel.
+
+ This service requires the 'services' module to be loaded, as well
+as a population of nicknames in the 'config/spamserv/nicklist.txt' directory.
+The module itself assumes that there are nicknames supplied in the .txt file,
+delimited by a new line.
+
+ There is some documentation of this module, in the form of
+/MSG SpamServ HELP
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::64bit;
+
+use strict;
+use Exporter qw( import );
+BEGIN {
+ require Config;
+
+ require constant;
+ import constant { HAS_64BIT_INT => ($Config::Config{use64bitint} eq 'define'), };
+ our @EXPORT = qw( HAS_64BIT_INT );
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Agent;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw(
+ is_agent is_agent_in_chan
+ agent_connect agent_quit agent_quit_all
+ agent_join agent_part set_agent_umode
+ agent_sync is_invalid_agentname
+); }
+
+use SrSv::Process::InParent qw(
+ is_agent is_agent_in_chan
+ agent_connect agent_quit agent_quit_all
+ agent_join agent_part agent_sync
+ whois_callback kill_callback
+);
+
+use SrSv::Conf2Consts qw(main);
+
+use SrSv::Debug;
+use SrSv::Unreal::Tokens qw( :tokens );
+use SrSv::Unreal::Base64 qw(itob64);
+use SrSv::IRCd::State qw(synced $ircd_ready %IRCd_capabilities);
+use SrSv::IRCd::IO qw(ircsend ircsendimm);
+use SrSv::IRCd::Event qw(addhandler);
+use SrSv::IRCd::Validate qw(valid_nick);
+use SrSv::RunLevel 'main_shutdown';
+
+# FIXME
+BEGIN { *SJB64 = \&ircd::SJB64 }
+
+our %agents;
+our @defer_join;
+
+addhandler('WHOIS', undef(), undef(), 'whois_callback', 1);
+addhandler('KILL', undef(), undef(), 'kill_callback', 1);
+
+sub is_agent($) {
+ my ($nick) = @_;
+ return (defined($agents{lc $nick}));
+}
+
+sub is_agent_in_chan($$) {
+ my ($agent, $chan) = @_;
+ $agent = lc $agent; $chan = lc $chan;
+
+ if($agents{$agent} and $agents{$agent}{CHANS} and $agents{$agent}{CHANS}{$chan}) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub agent_connect($$$$$) {
+ my ($nick, $ident, $host, $modes, $gecos) = @_;
+ my $time = time();
+
+ my @chans;
+ if(defined($agents{lc $nick}) and ref($agents{lc $nick}{CHANS})) {
+ @chans = keys(%{$agents{lc $nick}{CHANS}});
+ }
+
+ $agents{lc $nick}{PARMS} = [ @_ ];
+
+ $host = main_conf_local unless $host;
+ ircsend("@{[TOK_NICK]} $nick 1 $time $ident $host ".
+ (SJB64 ? itob64(main_conf_numeric) : main_conf_local).
+ " 1 $modes * :$gecos");
+
+ foreach my $chan (@chans) {
+ ircsend(":$nick @{[TOK_JOIN]} $chan");
+ # If we tracked chanmodes for agents, that would go here as well.
+ }
+}
+
+sub agent_quit($$) {
+ my ($nick, $msg) = @_;
+
+ delete($agents{lc $nick}{CHANS});
+ delete($agents{lc $nick});
+
+ ircsendimm(":$nick @{[TOK_QUIT]} :$msg");
+}
+
+sub agent_quit_all($) {
+ my ($msg) = @_;
+
+ my @agents;
+ @agents = keys(%agents);
+
+ foreach my $a (@agents) {
+ agent_quit($a, $msg);
+ }
+}
+
+sub is_invalid_agentname($$$) {
+ my ($botnick, $botident, $bothost) = @_;
+
+ unless(valid_nick($botnick)) {
+ return "Invalid nickname.";
+ }
+ unless($botident =~ /^[[:alnum:]_]+$/) {
+ return "Invalid ident.";
+ }
+ unless($bothost =~ /^[[:alnum:].-]+$/) {
+ return "Invalid vhost.";
+ }
+ unless($bothost =~ /\./) {
+ return "A vhost must contain at least one dot.";
+ }
+ return undef;
+}
+
+sub agent_join($$) {
+ my ($agent, $chan) = @_;
+
+ if($agents{lc $agent}) {
+ $agents{lc $agent}{CHANS}{lc $chan} = 1;
+ ircsend(":$agent @{[TOK_JOIN]} $chan");
+ } else {
+ if($ircd_ready) {
+ print "Tried to make nonexistent agent ($agent) join channel ($chan)" if DEBUG;
+ } else {
+ print "Deferred join: $agent $chan\n" if DEBUG;
+ push @defer_join, "$agent $chan";
+ }
+ }
+}
+
+sub agent_part($$$) {
+ my ($agent, $chan, $reason) = @_;
+
+ delete($agents{lc $agent}{CHANS}{lc $chan});
+ ircsend(":$agent @{[TOK_PART]} $chan :$reason");
+}
+
+sub set_agent_umode($$) {
+ my ($src, $modes) = @_;
+
+ ircsend(":$src @{[TOK_UMODE2]} $modes");
+}
+
+sub agent_sync() {
+ foreach my $j (@defer_join) {
+ print "Processing join: $j\n" if DEBUG;
+ my ($agent, $chan) = split(/ /, $j);
+ agent_join($agent, $chan);
+ }
+ undef(@defer_join);
+}
+
+sub whois_callback {
+#:wyvern.surrealchat.net 311 blah2 tabris northman SCnet-E5870F84.dsl.klmzmi.ameritech.net * :Sponsored by Skuld
+#:wyvern.surrealchat.net 307 blah2 tabris :is a registered nick
+#:wyvern.surrealchat.net 312 blah2 tabris wyvern.surrealchat.net :SurrealChat - aphrodite.wcshells.com - Chicago.IL
+#:wyvern.surrealchat.net 671 blah2 tabris :is using a Secure Connection
+#:wyvern.surrealchat.net 317 blah2 tabris 54 1118217330 :seconds idle, signon time
+#:wyvern.surrealchat.net 401 blah2 nikanoru :No such nick/channel
+#:wyvern.surrealchat.net 311 blah2 somebot bot SCnet-DA158DBF.hsd1.nh.comcast.net * :Some sort of bot
+#:wyvern.surrealchat.net 312 blah2 somebot nascent.surrealchat.net :SurrealChat - Hub
+#:wyvern.surrealchat.net 335 blah2 somebot :is a Bot on SurrealChat.net
+#:wyvern.surrealchat.net 318 blah2 tabris,nikanoru,somebot :End of /WHOIS list.
+
+# Also reference http://www.alien.net.au/irc/irc2numerics.html
+
+ my ($src, $nicklist) = @_;
+
+ my @nicks = split(/\,/, $nicklist);
+ my @reply;
+ foreach my $nick (@nicks) {
+ if (is_agent($nick)) {
+ my ($nick, $ident, $host, $modes, $gecos) = @{$agents{lc $nick}{PARMS}};
+ $host = main_conf_local unless $host;
+ push @reply, ':'.main_conf_local." 311 $src $nick $ident $host * :$gecos";
+ push @reply, ':'.main_conf_local." 312 $src $nick ".main_conf_local.' :'.main_conf_info;
+ foreach my $mode (split(//, $modes)) {
+ if ($mode eq 'z') {
+ push @reply, ':'.main_conf_local." 671 $src $nick :is using a Secure Connection";
+ }
+ elsif($mode eq 'S') {
+ #313 tab ChanServ :is a Network Service
+ push @reply, ':'.main_conf_local." 313 $src $nick :is a Network Service";
+ }
+ elsif($mode eq 'B') {
+ #335 blah2 TriviaBot :is a Bot on SurrealChat.net
+ push @reply, ':'.main_conf_local.
+ " 335 $src $nick :is a \002Bot\002 on ".$IRCd_capabilities{NETWORK};
+ }
+ }
+ }
+ else {
+ push @reply, ':'.main_conf_local." 401 $src $nick :No such service";
+ }
+
+ }
+ push @reply, ':'.main_conf_local." 318 $src $nicklist :End of /WHOIS list.";
+ ircsend(@reply);
+}
+
+sub kill_callback($$$$) {
+ my ($src, $dst, $path, $reason) = @_;
+ if (defined($agents{lc $dst})) {
+ if (defined ($agents{lc $dst}{KILLED}) and ($agents{lc $dst}{KILLED} == time())) {
+ if ($agents{lc $dst}{KILLCOUNT} > 3) {
+ ircd::debug("Caught in a kill loop for $dst, dying now.");
+ main_shutdown;
+ } else {
+ $agents{lc $dst}{KILLCOUNT}++;
+ }
+ } else {
+ $agents{lc $dst}{KILLED} = time();
+ $agents{lc $dst}{KILLCOUNT} = 1;
+ }
+
+ if($src =~ /\./) {
+ # let's NOT loopback this event
+ ircsendimm(':'.main_conf_local.' '."@{[TOK_KILL]} $dst :Nick Collision");
+ } elsif (defined($agents{lc $src})) {
+ # Do Nothing.
+ } else {
+ ircd::irckill($main::rsnick, $src, "Do not kill services agents.");
+ }
+
+ &agent_connect(@{$agents{lc $dst}{PARMS}}) if synced();
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::ChanReg::Flags;
+
+=head1 NAME
+
+SrSv::ChanReg::Flags - Manage flags of registered channels.
+
+=cut
+
+use strict;
+
+use Exporter 'import';
+
+BEGIN {
+ my %constants = (
+ #current chanreg.flags definition limits us to 16 of these. or 32768 as last flag
+ CRF_OPGUARD => 1,
+ CRF_LEAVEOP => 2,
+ CRF_VERBOSE => 4,
+ CRF_HOLD => 8,
+ CRF_FREEZE => 16,
+ CRF_BOTSTAY => 32,
+ CRF_CLOSE => 64,
+ CRF_DRONE => 128,
+ CRF_SPLITOPS => 256,
+ CRF_LOG => 512,
+ CRF_AUTOVOICE => 1024,
+ CRF_WELCOMEINCHAN => 2048,
+ CRF_NEVEROP => 4096,
+ CRF_NOCLONES => 8192,
+ );
+
+ our @EXPORT = (qw(cr_chk_flag cr_set_flag), keys(%constants));
+
+ require constant; import constant (\%constants);
+}
+
+use SrSv::MySQL '$dbh';
+use SrSv::Process::Init;
+
+our ($set_flags, $get_flags, $set_flag, $unset_flag);
+
+proc_init {
+ $set_flags = $dbh->prepare("UPDATE chanreg SET flags=? WHERE chan=?");
+ $get_flags = $dbh->prepare("SELECT flags FROM chanreg WHERE chan=?");
+ $set_flag = $dbh->prepare("UPDATE chanreg SET flags=(flags | (?)) WHERE chan=?");
+ $unset_flag = $dbh->prepare("UPDATE chanreg SET flags=(flags & ~(?)) WHERE chan=?");
+
+};
+
+sub cr_set_flag($$$) {
+ my ($chan, $flag, $sign) = @_;
+ my $cn = $chan->{CHAN};
+
+ if($sign >= 1) {
+ $chan->{FLAGS} = ( ( defined $chan->{FLAGS} ? $chan->{FLAGS} : 0 ) | $flag );
+ $set_flag->execute($flag, $cn);
+ } else {
+ $chan->{FLAGS} = ( ( defined $chan->{FLAGS} ? $chan->{FLAGS} : 0 ) & ~($flag) );
+ $unset_flag->execute($flag, $cn);
+ }
+}
+
+sub cr_chk_flag($$;$) {
+ my ($chan, $flag, $sign) = @_;
+ my $cn = $chan->{CHAN};
+ $sign = 1 unless defined($sign);
+
+ my $flags;
+ unless (exists($chan->{FLAGS})) {
+ $get_flags->execute($cn);
+ ($chan->{FLAGS}) = $get_flags->fetchrow_array;
+ $get_flags->finish();
+ }
+ $flags = $chan->{FLAGS};
+
+ return ($sign ? ($flags & $flag) : !($flags & $flag));
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Conf;
+
+use strict;
+
+use SrSv::SimpleHash qw(read_hash);
+
+our %conffiles;
+
+=cut
+our $prefix;
+BEGIN {
+ if(main::PREFIX()) {
+ $prefix = main::PREFIX();
+ } else {
+ $prefix = '.';
+ }
+}
+=cut
+
+sub install_conf($$) {
+ no strict 'refs';
+ my ($pkg, $file) = @_;
+
+ *{"${pkg}::$file\_conf"} = $conffiles{$file};
+}
+
+sub import {
+ my ($pkg, @files) = @_;
+
+ foreach my $file (@files) {
+ unless(defined $conffiles{$file}) {
+ $conffiles{$file} = { read_hash(main::PREFIX()."/config/$file.conf") };
+ }
+
+ install_conf(caller(), $file);
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU Lesser General Public License as published
+# by the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Conf::Parameters;
+
+use strict;
+
+our %params;
+
+sub import {
+ my (undef, $file, $data) = @_;
+
+ die "Configuration parameters already defined" if exists $params{$file};
+
+ $params{$file} = $data;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Conf::main;
+
+use SrSv::Conf::Parameters main => [
+ qw(local remote port numeric pass load email replyto),
+ [info => 'SurrealServices'],
+ [procs => 4],
+ [diag => '#Diagnostics'],
+ [netname => 'Network'],
+ [sig => 'Thank you for chatting with us.'],
+ [unsyncserver => undef],
+ [nomail => undef],
+ [logmail => undef],
+ [hashed_passwords => undef],
+ [ban_webchat_prefixes => 'java|htIRC'],
+ [ipv6 => 0], # not enabled by default as not all systems support it
+ [tokens => 1], # turn off for debugging, so debug-output is easier to read
+ [highqueue => 20],
+ [operchan => undef],
+];
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Conf::services;
+
+use SrSv::Conf::Parameters services => [
+ [noexpire => undef],
+ [nickexpire => 21],
+ [vacationexpire => 90],
+ [nearexpire => 7],
+ [chanexpire => 21],
+ [validate_email => undef],
+ [validate_expire => 1],
+ [clone_limit => 3],
+ [chankilltime => 86400],
+
+ [default_protect => 'normal'],
+ [default_chanbot => undef],
+ [default_channel_mlock => '+nrt'],
+ [old_user_age => 300],
+ [chanreg_needs_oper => 0],
+
+ [log_overrides => 0],
+
+ [botserv => undef],
+ [nickserv => undef],
+ [chanserv => undef],
+ [memoserv => undef],
+ [adminserv => undef],
+ [operserv => undef],
+ [hostserv => undef],
+
+];
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Conf::sql;
+
+use SrSv::Conf::Parameters sql => [
+ qw(mysql_user mysql_pass mysql_db),
+ [server_prepare => 0],
+];
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU Lesser General Public License as published
+# by the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Conf2Consts;
+
+use strict;
+
+use Carp 'croak';
+
+use SrSv::SimpleHash qw(read_hash);
+use SrSv::Conf::Parameters ();
+
+#use SrSv::Util qw( PREFIX CWD );
+# This is in main
+BEGIN {
+ *CWD = \&main::CWD;
+ *PREFIX = \&main::PREFIX;
+}
+
+=head1 NAME
+
+Util::Conf2Consts
+
+=head1 DESCRIPTION
+
+Given a file full of key=value pairs, produce constant functions for the
+key that contains value.
+
+=head1 SYNOPSIS
+
+use Util::Conf2Consts ( main sql );
+
+which will load the files main.conf and sql.conf, and load them into
+your namespace.
+
+=cut
+
+our (%files, %defaults);
+
+*defaults = \%SrSv::Conf::Parameters::params;
+
+sub canonical($) {
+ my $key = shift;
+ $key =~ tr/-/_/;
+ $key = lc $key;
+}
+
+sub make_const($) {
+ my $x = shift;
+ return sub() { $x };
+}
+
+sub get_file($) {
+ my ($file) = @_;
+
+ return $files{$file}
+ # We cache the config so we only load the files once.
+ if exists $files{$file};
+ croak qq{Tried to use unknown conf file "$file"} unless $defaults{$file};
+
+ my $data = {};
+ {
+ my %in_data = read_hash(PREFIX . "/config/$file.conf");
+ foreach (keys %in_data) {
+ $data->{canonical($_)} = $in_data{$_};
+ }
+ }
+
+ my %known_params;
+
+ foreach my $default (@{$defaults{$file}}) {
+ my $key;
+
+ if(ref $default) {
+ ($key, my $value) = @$default;
+
+ $data->{$key} = $value
+ # initialize value from default value (SrSv::Parameters::Conf)
+ # unless we have a value from the config-file
+ unless exists $data->{$key};
+ }
+ else {
+ $key = $default;
+ die qq{ERROR: Configuration file $file.conf must contain a "$key" setting.\n\n}
+ unless exists $data->{$key};
+ }
+
+ $known_params{$key} = 1;
+ }
+
+ foreach my $key (keys %$data) {
+ if($known_params{$key}) {
+ $data->{$key} = make_const $data->{$key};
+ }
+ else {
+ warn qq{Warning: Unknown setting "$key" in configuration file $file.conf\n};
+ delete $data->{$key};
+ }
+ }
+
+ return ($files{$file} = $data);
+}
+
+sub install_vars($$$) {
+ no strict 'refs';
+ no warnings;
+ my ($pkg, $file, $data) = @_;
+
+ while(my ($key, $value) = each %$data) {
+ *{"${pkg}\::${file}_conf_${key}"} = $value;
+ }
+}
+
+sub import {
+ my ($pkg, @files) = @_;
+
+ foreach my $file (@files) {
+ install_vars caller, $file, get_file $file;
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::DB::Schema;
+
+use strict;
+
+use SrSv::MySQL qw( $dbh connectDB disconnectDB );
+use SrSv::Conf2Consts qw( sql );
+
+BEGIN {
+ *PREFIX = \&main::PREFIX;
+}
+
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT = qw(
+ upgrade_schema check_schema find_newest_schema
+ do_sql_file );
+};
+
+sub find_newest_schema() {
+ opendir((my $dh), "@{[PREFIX]}/sql/");
+ my @schemas;
+ while (my $dentry = readdir($dh)) {
+ next if ($dentry =~ /^\.\.?$/);
+ if($dentry =~ /^(\d+)\.sql$/) {
+ push @schemas, $1;
+ }
+ }
+ @schemas = reverse sort { $a <=> $b } @schemas;
+ return $schemas[0];
+}
+sub upgrade_schema($) {
+ my ($ver) = @_;
+ opendir((my $dh), "@{[PREFIX]}/sql/");
+ my @schemas;
+ while (my $dentry = readdir($dh)) {
+ next if ($dentry =~ /^\.\.?$/);
+ if($dentry =~ /^(\d+)\.sql$/) {
+ push @schemas, $1;
+ }
+ }
+ @schemas = sort { $a <=> $b } @schemas;
+ while(scalar(@schemas) && $schemas[0] <= $ver) {
+ shift @schemas;
+ }
+ foreach my $schema (@schemas) {
+ #print "@{[PREFIX]}/sql/${schema}.sql\n";
+ do_sql_file("@{[PREFIX]}/sql/${schema}.sql");
+ }
+}
+sub check_schema() {
+ my $disconnect = 0;
+ if(!defined($dbh)) {
+ connectDB();
+ $disconnect = 1;
+ }
+ # SHOW TABLES WHERE doesn't work for MySQL 4.x.
+ my $tables = $dbh->selectall_arrayref("SHOW TABLES");
+ my ($found, undef) = grep { m"srsv_schema" } map { $_->[0] } @$tables;
+ if(defined $found) {
+ } else {
+ return 0;
+ }
+ my $findSchemaVer = $dbh->prepare("SELECT `ver` FROM `srsv_schema`");
+ $findSchemaVer->execute();
+ my ($ver) = $findSchemaVer->fetchrow_array();
+ $findSchemaVer->finish();
+ disconnectDB() if $disconnect;
+ return $ver;
+}
+
+sub do_sql_file($) {
+ my $file = shift;
+ open ((my $SQL), $file) or die "$file: $!\n";
+ my $sql;
+
+ while(my $x = <$SQL>) {
+ unless($x =~ /^#/ or $x eq $/) {
+ $sql .= "$x$/";
+ }
+ }
+ foreach my $line (split(/;/s, $sql)) {
+ $dbh->do($line);
+ }
+}
+
+1;
--- /dev/null
+# This file is part of Invid
+#
+# Invid is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Lesser General Public
+# License version 2.1 as published by the Free Software Foundation.
+
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
+
+# You should have received a copy of the GNU Lesser General Public
+# License along with this library; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+# Copyright Adam Schrotenboer <adam@tabris.net> 2007, 2008
+#
+
+# This code is based in large part on the MySQL::Stub from SrSv, as well as
+# the DB::Sub from M2000's CMS.
+
+=head1 NAME
+
+Invid::DB::Stub - Create functions for SQL queries
+
+=cut
+
+package SrSv::DB::StubGen;
+
+use strict;
+use warnings;
+
+require SrSv::DB::StubGen::Stub;
+
+sub import {
+ my $package = caller;
+
+ shift @_; # Remove package name from arg list.
+ my %stubhash = @_; # Basically we coerce the list back into a hash.
+ my $generator = $stubhash{generator};
+ my $dbh = $stubhash{dbh};
+ my $sub = sub {
+ import SrSv::DB::StubGen::Stub ($package, $dbh, @_);
+ };
+
+ # Export subroutine into caller's namespace.
+ {
+ no strict 'refs';
+ *{"${package}::${generator}"} = $sub;
+ }
+}
+
+__END__
+
+=head1 SYNOPSIS
+
+ use SrSv::DB::StubGen {
+ dbh => $dbh
+ generator => 'main_sql_stub',
+ };
+
+=head1 PURPOSE
+
+The point of this is that although SrSv::DB::Stub is bloody useful, it
+only lets you use one $dbh per program. What if you have more than one
+database?
+
+=head1 DESCRIPTION
+
+See SrSv::DB::Stub for how you use the generator function.
+
+However, instead of
+
+use SrSv::DB::Stub ( ... )
+
+one uses instead
+
+main_sql_stub ( ... )
+
+=cut
--- /dev/null
+# This file is part of Invid
+#
+# Invid is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Lesser General Public
+# License version 2.1 as published by the Free Software Foundation.
+
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
+
+# You should have received a copy of the GNU Lesser General Public
+# License along with this library; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+# Copyright Adam Schrotenboer <adam@tabris.net> 2007, 2008
+#
+
+# This code is based in large part on the MySQL::Stub from SrSv, as well as
+# the DB::Sub from M2000's CMS.
+
+=head1 NAME
+
+SrSv::DB::StubGen::Stub - Create functions for SQL queries
+
+=cut
+
+package SrSv::DB::StubGen::Stub;
+use strict;
+
+use Carp qw( confess );
+
+our %create_sub = (
+ # For INSERT queries, returns last_insert_id.
+ INSERT => sub($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ eval { $q->execute(@_); };
+ if($@) { confess($@) }
+ $q->finish();
+ return $dbh->last_insert_id(undef, undef, undef, undef);
+ }
+ },
+
+ # For UPDATE or DELETE queries; returns number of rows affected.
+ NULL => sub ($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ my $ret;
+ eval { $ret = $q->execute(@_) + 0; }; # Force it to be a number.
+ if($@) { confess($@) }
+ $q->finish();
+ return ($ret);
+ }
+ },
+
+ # For queries that return only one row with one columns; returns a scalar.
+ SCALAR => sub ($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ eval { $q->execute(@_); };
+ if($@) { confess($@) }
+ my $scalar;
+ eval { ($scalar) = $q->fetchrow_array; };
+ if($@) { confess($@) }
+ $q->finish();
+ return $scalar;
+ }
+ },
+
+ # For queries that return only one row with multiple columns; returns a 1-dimensional array.
+ ROW => sub ($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ eval { $q->execute(@_); };
+ if($@) { confess($@) }
+ my @row;
+ eval { @row = $q->fetchrow_array; };
+ if($@) { confess($@) }
+
+ $q->finish();
+ return @row;
+ }
+ },
+
+ # For queries that return just a single column, multiple rows
+ # return a 1D array.
+ COLUMN => sub ($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ eval { $q->execute(@_); };
+ if($@) { confess($@) }
+ my $arrayref;
+ eval { $arrayref = $q->fetchall_arrayref() };
+ if($@) { confess($@) }
+
+ $q->finish();
+ return map({ $_->[0] } @$arrayref);
+ }
+ },
+
+
+ # For other queries; returns an arrayref.
+ ARRAY => sub ($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ #die "improper number of parameters for $sth\n" unless $q->{NUM_OF_PARAMS} == scalar(@_);
+ eval { $q->execute(@_); };
+ if($@) { confess($@) }
+ if ($q->err) { say ("ERROR: ", $q->err); }
+ my $arrayref;
+ eval { $arrayref = $q->fetchall_arrayref() };
+ if($@) { confess($@) }
+
+ $q->finish();
+ return @$arrayref;
+ }
+ },
+
+ ARRAYREF => sub ($) {
+ my $dbh = shift @_;
+ my $q = shift;
+ return sub {
+ $q->execute(@_);
+ my $arrayref;
+ eval { $arrayref = $q->fetchall_arrayref() };
+ if($@) { confess($@) }
+ $q->finish();
+ return ($arrayref);
+ }
+ },
+);
+
+sub import {
+ shift @_; # Remove most-recent-caller package name from arg list.
+
+ # this is the _original_ package caller
+ my $package = shift @_;
+ my $dbh = shift @_;
+
+ my $printError = $dbh->{PrintError};
+ $dbh->{PrintError} = 1;
+
+ foreach (@_) {
+ my ($name, $type, $query) = @$_;
+=cut
+ $query =~ s/\n/ /gm;
+ $query =~ s/\s{2,}/ /g;
+ print "$query \n";
+=cut
+ # Prepare query
+ my $q = $dbh->prepare($query);
+
+ # Create subroutine.
+ my $sub = $create_sub{$type}->($dbh, $q);
+
+ # Export subroutine into caller's namespace.
+ {
+ no strict 'refs';
+ *{"${package}::${name}"} = $sub;
+ }
+ }
+ $dbh->{PrintError} = $printError;
+}
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Debug;
+
+use strict;
+
+our @subs;
+BEGIN {
+ @subs = (
+ sub () { 0 },
+ sub () { 1 }
+ );
+}
+
+our %debug_pkgs;
+our $enabled;
+
+sub enable {
+ $enabled = 1;
+}
+
+sub import {
+ no strict 'refs';
+ no warnings 'uninitialized';
+ my ($package) = caller;
+
+ if($debug_pkgs{ALL}) {
+ *{"$package\::DEBUG"} = $subs[1];
+ } else {
+ *{"$package\::DEBUG"} = $subs[$debug_pkgs{$package}];
+ }
+
+ *{"$package\::DEBUG_ANY"} = $subs[$enabled];
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package SrSv::Email;
+use strict;
+
+use SrSv::Conf2Consts qw(main);
+use SrSv::IRCd::State qw( %IRCd_capabilities );
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw( send_email validate_email ) }
+
+sub send_email($$$) {
+ my ($dst, $subj, $msg) = @_;
+ return if main_conf_nomail;
+
+ open ((my $EMAIL), '|-', '/usr/sbin/sendmail', '-t');
+ print $EMAIL 'From: '.main_conf_email."\n";
+ print $EMAIL 'To: '.$dst."\n";
+ print $EMAIL 'Reply-to: '.main_conf_replyto."\n" if main_conf_replyto;
+ print $EMAIL 'Subject: '.$subj."\n\n";
+ print $EMAIL "This is an automated mailing from the IRC services at " . $IRCd_capabilities{NETWORK} . ".\n\n";
+ print $EMAIL $msg;
+ print $EMAIL "\n\n" . main_conf_sig . "\n";
+ close $EMAIL;
+}
+
+sub validate_email($) {
+ my ($email) = @_;
+
+ $email =~ /.+\.(\w+)$/;
+ my $tld = $1;
+ if(
+# $email =~ /^(?:[0-9a-z]+[-._+&])*[0-9a-z]+@(?:[-0-9a-z]+[.])+[a-z]{2,6}$/i and
+ $email =~ /^[^@]+@(?:[-0-9a-z]+[.])+[a-z]{2,6}$/i and
+ $email !~ /^(?:abuse|postmaster|noc|security|spamtrap)\@/i and
+ defined($core::ccode{uc $tld})
+ ) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Errors;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw($err_deny $err_email $err_pass) }
+
+*err_deny = \'Permission denied.';
+*err_email = \'Your email address looks funny.';
+*err_pass = \'Invalid password.';
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Hash::Passwords;
+
+=head1 NAME
+
+SrSv::Hash::Passwords - Handle passwords, hashing, and verifying the hashes.
+
+=cut
+
+use strict;
+use SrSv::Hash::SaltedHash qw( makeHash verifyHash );
+use SrSv::Conf qw( main );
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT = qw( hash_pass validate_pass is_hashed );
+}
+
+=head2
+
+ hash_pass($pass)
+ If hashed-passwords is enabled in main.conf, returns a hashed password in a string.
+ Otherwise returns $pass unmodified.
+
+=cut
+
+sub hash_pass($) {
+ my ($pass) = @_;
+ if($main_conf{'hashed-passwords'}) {
+ return makeHash($pass);
+ }
+ else {
+ return $pass;
+ }
+}
+
+=head2
+
+ validate_pass($hashedPass, $pass)
+ Decodes the hashedPass.
+ - If $hashedPass is a valid SSHA256 hash-string, it and determines whether $pass matches $hashedPass
+ - If $hashedPass is not a valid SSHA256 hash-string, it returns ($hashedPass eq $pass)
+
+=cut
+sub validate_pass($$) {
+ my ($hashedPass, $pass) = @_;
+ if (my $hashType = is_hashed($hashedPass)) {
+ return verifyHash($hashedPass, $pass);
+ } else {
+ return $hashedPass eq $pass;
+ }
+}
+
+sub is_hashed($) {
+ my ($in) = @_;
+ if ($in =~ /^\{S(.*)\}/ or $in =~ m/^(?:SHA256):v\d+-\d+-r\d+:[A-Za-z0-9+\/=]+:/) {
+ return 1;
+ } else {
+ return undef;
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Hash::Random;
+
+=head1 NAME
+
+SrSv::Hash::Random - generates random strings for use as salt
+
+=cut
+
+use strict;
+#use SrSv::Conf qw( main );
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT = qw( randomByte randomBytes );
+}
+
+sub randomByte() {
+ return chr(int(rand(256)));
+}
+
+sub randomBytes($) {
+ my ($count) = @_;
+ my $string;
+ for(1..$count) {
+ $string .= randomByte();
+ }
+ return $string;
+}
+
+=cut
+sub randomBytes($) {
+ my ($count) = @_;
+ open((my $fh), '<', '/dev/urandom');
+ binmode $fh;
+ my $bytes = '';
+ sysread($fh, $bytes, $count);
+ close $fh;
+ return $bytes;
+}
+
+sub randomByte() {
+ return randomBytes(1);
+}
+=cut
+
+1;
+
--- /dev/null
+#########################################################################################
+## ##
+## Copyright(c) 2007 M2000, Inc. ##
+## ##
+## File: SaltedHash.pm ##
+## Author: Adam Schrotenboer ##
+## ##
+## ##
+## Description ##
+## =========== ##
+## Produces salted hashes for various uses. ##
+## This module is licensed under the Lesser GNU Public License version 2.1 ##
+## ##
+## Revision History ##
+## ================ ##
+## 11/13/07: Initial version. ##
+## ##
+## ##
+#########################################################################################
+## ##
+## For more details refer to the implementation specification document ##
+## DRCS-xxxxxx Section x.x ##
+## ##
+#########################################################################################
+package SrSv::Hash::SaltedHash;
+
+use strict;
+
+=head1 NAME
+
+SaltedHash
+
+=head1 SYNOPSIS
+
+use SaltedHash;
+
+=head1 DESCRIPTION
+
+Produces and verifies salted hashes.
+
+=head2 NOTE
+
+ This module currently only supports SHA256, and requires Digest::SHA.
+ If Digest::SHA is not available, it will however fallback to an included copy of Digest::SHA::PurePerl
+
+=cut
+
+
+BEGIN {
+ if(eval { require Digest::SHA; } ) {
+ import Digest::SHA qw( sha256_base64 sha256 sha1 );
+ print "SrSv::Hash::SaltedHash using Digest::SHA\n";
+ }
+ elsif(eval { require Digest::SHA::PurePerl; } ){
+ import Digest::SHA::PurePerl qw( sha256_base64 sha256 sha1 );
+ print "SrSv::Hash::SaltedHash using Digest::SHA::PurePerl\n";
+ } else {
+ die "Unable to find a suitable SHA implementation\n";
+ }
+}
+use Digest::MD5;
+
+=item Hash Notes
+
+ SHA512 requires 64bit int operations, and thus will be SLOW on 32bit platforms.
+ Current hash string length with SHA256 and 16byte (128bit) salts is 85 characters
+ Be aware that SHA512 with 16byte salt would take approximately ~130 characters
+ So make sure that your password field can hold strings large enough.
+ It is generally considered pointless to make your salt
+ longer than your hash, so 32bytes is longest that is useful
+ for SHA256 and 64 is longest for SHA512.
+ SrSv has a limit of 127 characters for password strings, so don't use SHA512.
+
+=cut
+use Exporter 'import';
+BEGIN {
+ my %constants = (
+ HASH_ALGORITHM => 'SHA256',
+ HASH_SALT_LEN => 16,
+ HASH_ROUNDS => 1,
+ );
+ my $version = 'v1-'.$constants{HASH_SALT_LEN}.'-r'.$constants{HASH_ROUNDS};
+ $constants{HASH_VERSION} = $version;
+ our @EXPORT = qw( makeHash verifyHash );
+ our @EXPORT_OK = ( @EXPORT, keys(%constants), qw( extractMeta extractSalt padBase64 makeHash_v0 makeHash_v1 ));
+ our %EXPORT_TAGS = ( constants => [keys(%constants)] );
+ require constant; import constant (\%constants);
+}
+
+
+use MIME::Base64 qw( encode_base64 decode_base64 );
+use SrSv::Hash::Random qw( randomBytes randomByte );
+
+=item makeHash($;$$$)
+
+ makeHash($secret, $salt, $algorithm, $version)
+
+ Salt is assumed to be a BINARY STRING.
+
+ Algorithm currently can only be 'SHA256'
+
+=cut
+
+sub makeHash($;$$$) {
+ return makeHash_v1(@_);
+}
+
+=item makeHash_v1($;$$$)
+
+ makeHash_v1 ($secret, $salt, $algorithm, $version)
+
+ returns a string that can be processed thusly
+ my ($algorithm, $version, $salt, $hash) = split(':', $string);
+
+ my ($revision, $saltsize, $rounds) = split('-', $version);
+
+=cut
+
+sub makeHash_v1($;$$$) {
+ my ($secret, $salt, $algorithm, $version) = @_;
+ $algorithm = HASH_ALGORITHM unless $algorithm;
+ $salt = makeBinSalt(HASH_SALT_LEN) unless $salt;
+ $version = HASH_VERSION unless $version;
+ my $string = "$algorithm:$version:";
+ $string .= encode_base64($salt, '').':';
+ $string .= padBase64(__makeHash($secret . $salt, $algorithm));
+ return $string;
+}
+
+sub makeHash_vBulletin($;$$$) {
+ my ($secret, $salt, $algorithm, $version) = @_;
+ $algorithm = 'md5' unless $algorithm;
+ $salt = makeBinSalt(3) unless $salt;
+ $version = 2 unless $version;
+ my $string = "$algorithm:$version:";
+ $string .= encode_base64($salt, '').':';
+ $string .= md5_base64(md5_hex($secret) . $salt);
+ return $string;
+}
+
+sub __makeHash($$) {
+ my ($plaintext, $algorithm) = @_;
+ $algorithm = 'sha256';
+ if($algorithm =~ /^sha256$/i) {
+ return sha256_base64($plaintext);
+ } else {
+ # Other hash algos haven't been implemented yet
+ die "Unknown hash algorithm \"$algorithm\" \"$plaintext\"\n";
+ }
+}
+
+sub makeHash_v0($;$$) {
+ my ($secret, $salt, $algorithm) = @_;
+ $algorithm = 'SHA256' unless $algorithm;
+ $salt = makeBinSalt(4) unless $salt;
+ my $string = "{S$algorithm}";
+ if($algorithm eq 'SHA256') {
+ $string .= encode_base64(sha256($secret . $salt) . $salt, '');
+ } elsif ($algorithm eq 'SHA') {
+ $string .= encode_base64(sha1($secret . $salt) . $salt, '');
+ }
+ return $string;
+}
+
+sub padBase64($) {
+ my ($b64_digest) = @_;
+ while (length($b64_digest) % 4) {
+ $b64_digest .= '=';
+ }
+ return $b64_digest;
+}
+
+=item makeHash
+
+ verifyHash($hash, $plain)
+
+ Verifies that a given $plain matches $hash
+
+=cut
+
+sub verifyHash($$) {
+ my ($hash, $plain) = @_;
+ my ($algorithm, $version, $salt) = extractMeta($hash);
+ my $hash2;
+ if($version eq 'v0') {
+ $hash2 = makeHash_v0($plain, $salt, $algorithm);
+ } elsif($version eq 'vBulletin') {
+ $hash2 = makeHash_vBulletin($plain, $salt, $algorithm);
+ } else {
+ $hash2 = makeHash_v1($plain, $salt, $algorithm, $version);
+ }
+
+ return ($hash eq $hash2 ? 1 : 0);
+}
+
+sub makeBinSalt(;$) {
+ my ($len) = @_;
+ $len = HASH_SALT_LEN unless $len;
+ return randomBytes($len);
+}
+
+=item makeHash
+
+ extractMeta($hash)
+
+ return ($algorithm, $version, $salt) from $hash.
+
+=cut
+sub extractMeta($) {
+ my ($input) = @_;
+ if($input =~ /^\{S(\S+)\}(.*)$/) {
+ my $algorithm = $1;
+ my $saltedBinHash = decode_base64($2);
+ my $salt = substr($saltedBinHash, -4);
+ return ($algorithm, 'v0', $salt);
+ } else {
+ my ($algorithm, $version, $salt, $hash) = split(':', $input);
+ return ($algorithm, $version, decode_base64($salt));
+ }
+}
+
+=item makeHash
+
+ extractSalt($hash)
+
+ return $salt from $hash.
+
+=cut
+sub extractSalt($) {
+ my ($input) = @_;
+ my ($algorithm, $version, $salt) = extractMeta($input);
+ return $salt;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package SrSv::Help;
+use strict;
+
+use SrSv::User::Notice qw( notice );
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT = qw( sendhelp readhelp );
+ my %constants = ( HELP_PATH => main::PREFIX()."/help/" );
+ require constant; import constant \%constants;
+}
+
+sub readhelp($) {
+ my ($file_name) = @_;
+ my @array;
+
+ open ((my $file_handle), $file_name) or return undef();
+
+ while(my $x = <$file_handle>) {
+ next if $x =~ /^#/;
+ chomp $x;
+ $x =~ s/\%B/\002/g;
+ $x =~ s/\%U/\037/g; # chr(31)
+ $x =~ s/\%E(.*?)\%E/eval($1)/eg;
+
+ $x = ' ' if $x eq '';
+ push @array, $x;
+ }
+
+ close $file_handle;
+
+ return (' ', @array, ' --');
+}
+
+sub sendhelp($@) {
+ my ($user, @subject) = @_;
+
+ @subject = split(/ /, $subject[0]) if(@subject == 1);
+
+ # change any / or . to _
+ # this is to prevent ppl from using this to access
+ # files outside of the helpdir.
+ # also lowercase the @subject components
+ foreach my $s (@subject) {
+ $s = lc $s;
+ $s =~ s/[^a-z0-9\-]/_/g;
+ }
+
+ my $file = HELP_PATH . join('/', @subject) . '.txt';
+ my @array = readhelp($file);
+ unless($array[0]) {
+ notice($user, "No help for \002".join(' ',
+ @subject)."\002");
+ return;
+ }
+
+ notice($user, @array);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::HostMask;
+
+=head1 NAME
+
+SrSv::HostMask - Functions for manipulating hostmasks
+
+=head1 SYNOPSIS
+
+ use SrSv::HostMask qw(normalize_hostmask hostmask_to_regexp parse_mask parse_hostmask make_hostmask);
+
+=cut
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw( normalize_hostmask hostmask_to_regexp parse_mask parse_hostmask make_hostmask ) }
+
+=pod
+
+ normalize_hostmask($hostmask);
+
+ # Heuristically convert random stuff entered by the user to normal *!*@* form
+ $hostmask = normalize_hostmask($hostmask)
+
+
+=cut
+
+sub normalize_hostmask($) {
+ my ($in) = @_;
+ if($in !~ /[!@]/) { # we have to guess whether they mean nick or host
+ if($in =~ /\./) { # nicks can't contain dots, so assume host
+ #if($in =~ /\*/) {
+ return '*!*@' . $in;
+ #} else { # no wildcard, so add one
+ # return '*!*@*' . $in;
+ #}
+ } else { # no dots, so assume nick
+ return $in . '!*@*';
+ }
+ }
+
+ my @parts = ($in =~ /^(.*?)(?:!(.*?))(?:\@(.*?))?$/);
+ my $out;
+
+ for my $i (0..2) {
+ $parts[$i] = '*' unless length($parts[$i]);
+ $out .= $parts[$i] . @{['!', '@', '']}[$i];
+ };
+
+ return $out;
+}
+
+
+=pod
+
+ my $re = hostmask_to_regexp('*!*@*.aol.com');
+ if($hostmask =~ $re) {
+ # user is from AOL
+ # ...
+ }
+
+=cut
+
+sub hostmask_to_regexp($) {
+ my $mask = normalize_hostmask(shift);
+
+ $mask =~ s/([^a-zA-Z0-9?*])/\\$1/g;
+ $mask =~ s/\*/.*/g;
+ $mask =~ s/\?/./g;
+
+ return qr/^$mask$/i;
+}
+
+=pod
+
+ my ($nick, $ident, $host) = parse_mask($mask);
+
+ split a nick!ident@hostmask into components
+ also lets you just do @host, or nick!
+
+=cut
+
+sub parse_mask($) {
+ my ($mask) = @_;
+ my ($mnick, $mident, $mhost);
+
+ $mask =~ /^(.*?)(?:\!|\@|$)/;
+ $mnick = $1;
+
+ if($mask =~ /\!(.*?)(?:\@|$)/) {
+ $mident = $1;
+ } else {
+ $mident = '';
+ }
+
+ if($mask =~ /\@(.*?)$/) {
+ $mhost = $1;
+ } else {
+ $mhost = '';
+ }
+
+ return ($mnick, $mident, $mhost);
+}
+
+=pod
+
+ my ($ident, $host) = parse_hostmask($mask);
+
+ This is like parse_mask, but only will parse ident@host
+ TKL in particular will use this.
+ also could be used to parse email addresses
+
+=cut
+
+sub parse_hostmask($) {
+ my ($mask) = @_;
+ my ($mident, $mhost);
+
+ if($mask !~ /@/) {
+ return ('', $mask);
+ }
+ elsif($mask =~ /\!(.*?)(?:\@|$)/) {
+ $mident = $1;
+ } else {
+ $mident = '';
+ }
+
+ if($mask =~ /\@(.*?)$/) {
+ $mhost = $1;
+ } else {
+ $mhost = '';
+ }
+
+ return ($mident, $mhost);
+}
+
+=pod
+
+ make_hostmask($type, $nick, $ident, $host);
+
+ Some of this may be Unreal/cloak specific, but is mostly generic.
+ No IPv6 support yet.
+ $type is an integer, 0 - 10
+ 0 - *!user@host.domain
+ 1 - *!*user@host.domain
+ 2 - *!*@host.domain
+ 3 - *!*user@*.domain
+ 4 - *!*@*.domain
+ 5 - nick!user@host.domain
+ 6 - nick!*user@host.domain
+ 7 - nick!*@host.domain
+ 8 - nick!*user@*.domain
+ 9 - nick!*@*.domain
+ 10 - cross btwn 2 and 3, depending on if is a java-abcd1 ident or not
+
+ 10 is very SCnet specific (more accurately, it is specific to our java iframe)
+ our java iframe is _not_ open source [yet]. I do not know if it will be either.
+
+=cut
+use SrSv::Conf2Consts qw( main );
+our $ident_regexp = qr/^(@{[main_conf_ban_webchat_prefixes]})-/;
+
+sub make_hostmask($$$$) {
+ my ($type, $nick, $ident, $host) = @_;
+ no warnings 'prototype'; #we call ourselves
+
+ if($type == 10) {
+ if ($ident =~ $ident_regexp) {
+ return make_hostmask(3, $nick, $ident, $host);
+ }
+ else {
+ return make_hostmask(2, $nick, $ident, $host);
+ }
+ }
+
+ if($host =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) {
+ # IPv4 address, dotted quad.
+ my @octets = ($1, $2, $3, $4);
+ if($type =~ /^[3489]$/) {
+ $host = $octets[0].'.'.$octets[1].'.'.$octets[2].'.*';
+ }
+ }
+ elsif($host =~ /^[A-Z0-9]{7}\.[A-Z0-9]{8}\.[A-Z0-9]{7}\.IP$/) { # should probably be case-sensitive.
+ # 74BBBBF2.493EE1E3.CA7BA255.IP
+ if($type =~ /^[3489]$/) {
+ my @host = split(/\./, $host);
+ pop @host; #discard last token ('IP')
+ $host = '*.'.$host[2].'.IP'; # Unreal's cloak makes last group be the first two octets.
+ }
+ } else {
+ # we assume normal hostname
+ # We don't know what the cloak prefix will be, nor that it will be sane
+ # Or even that we'll have a normal cloaked host (it could be a vhost)
+ # So we can't restrict the character-class [much].
+ # This could be improved further by popping off the
+ # parts that are mostly numbers, if not a normal cloakhost.
+ if($type =~ /^[3489]$/) {
+ $host =~ /(.+?)\.(.+\.[a-z]{2,3})/i;
+ $host = "*.$2";
+ }
+ }
+
+ if($type =~ /^[1368]$/) {
+ $ident =~ s/^\~//;
+ $ident = "*$ident" unless (length($ident) > (ircd::IDENTLEN - 1));
+ } elsif($type =~ /^[2479]$/) {
+ $ident = '*';
+ }
+
+ if ($type < 5 and $type >= 0) {
+ $nick = '*';
+ }
+
+ return ($nick, $ident, $host);
+}
+
+1;
--- /dev/null
+package SrSv::IPv6;
+
+use Exporter qw( import );
+use SrSv::Conf2Consts qw( main );
+
+use SrSv::64bit;
+BEGIN {
+ our @EXPORT = qw( is_ipv6 get_ipv6_net get_ipv6_64 );
+ if(main_conf_ipv6) {
+ require Socket; import Socket;
+ require Socket6; import Socket6;
+ if(!HAS_64BIT_INT) {
+ eval {
+ require Math::BigInt;
+ import Math::BigInt try => 'GMP';
+ };
+ if($@) {
+ print STDERR "Running old version of perl/Math::BigInt.\n", $@, "Trying again.\n";
+ require Math::BigInt;
+ import Math::BigInt;
+ }
+ }
+ push @EXPORT, qw( AF_INET6 );
+ }
+}
+
+sub is_ipv6($) {
+ my ($addr) = @_;
+ if($addr =~ /^((?:\d{1,3}\.){3}\d{1,3})$/) {
+ return 0 unless wantarray;
+ return (0, $addr);
+ }
+ elsif($addr =~ /:ffff:((?:\d{1,3}\.){3}\d{1,3})$/) {
+ return 0 unless wantarray;
+ return (0, $1);
+ } else {
+ return 1 unless wantarray;
+ return (1, $addr);
+ }
+}
+
+
+sub get_ipv6_net($) {
+# grabs the top 64bits of the IPv6 addr.
+ my ($addr) = @_;
+ my $str = Socket6::inet_pton(AF_INET6, $addr);
+ my (@words) = unpack('H4H4H4H4H4H4H4H4', $str);
+ my $int = ( !HAS_64BIT_INT ? Math::BigInt->bzero() : 0 );
+ for(0..3) {
+ $int <<= 16;
+ $int |= hex($words[$_]);
+ }
+ return $int;
+}
+
+sub get_ipv6_64($) {
+ my ($addr) = @_;
+ my $str = Socket6::inet_pton(AF_INET6, $addr);
+ return join(":", unpack("H4H4H4H4", $str))."::/64";
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::IRCd::Event;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(addhandler callfuncs) }
+
+use SrSv::Debug;
+
+use SrSv::Conf2Consts qw( main );
+
+use SrSv::IRCd::Queue qw(ircd_enqueue);
+use SrSv::IRCd::State qw($ircline $ircline_real synced initial_synced);
+
+use SrSv::Message qw(add_callback message);
+
+# FIXME
+use constant {
+ # Wait For
+ WF_NONE => 0,
+ WF_NICK => 1,
+ WF_CHAN => 2,
+ WF_ALL => 3,
+};
+
+sub addhandler($$$$;$) {
+ my ($type, $src, $dst, $cb, $po) = @_;
+
+ if($cb !~ /::/) {
+ $cb = caller() . "::$cb";
+ }
+
+ print "Adding callback: $cb\n" if DEBUG;
+
+ my @cond = ( CLASS => 'IRCD', TYPE => $type );
+ push @cond, ( SRC => $src ) if($src);
+ push @cond, ( DST => $dst ) if($dst);
+
+ add_callback({
+ NAME => $cb,
+ TRIGGER_COND => { @cond },
+ CALL => 'SrSv::IRCd::Event::_realcall',
+ REALCALL => $cb,
+ PARENTONLY => $po,
+ });
+}
+
+our $last_highqueue = time();
+sub callfuncs {
+ my ($args, $sync, $wf, $message);
+
+ if(@_ == 4) {
+ $args = $_[3];
+ $sync = 1;
+ $wf = WF_NONE;
+ } else {
+ $args = $_[4];
+ $sync = 0;
+ $wf = $_[3];
+ }
+
+ $message = {
+ CLASS => 'IRCD',
+ TYPE => $_[0],
+ SYNC => $sync,
+ SRC => (defined($_[1]) ? $args->[$_[1]] : undef),
+ DST => (defined($_[2]) ? $args->[$_[2]] : undef),
+ WF => $wf,
+ IRCLINE => ($sync ? $ircline : $ircline_real),
+ ARGS => $args,
+ ON_FINISH => ($sync ? undef : 'SrSv::IRCd::Queue::finished'), # FIXME
+ SYNCED => [synced, initial_synced],
+ QUEUE_DEPTH => SrSv::IRCd::Queue::queue_size(),
+ };
+ if(initial_synced && ($message->{QUEUE_DEPTH} > main_conf_highqueue) && ($last_highqueue < time()-5)) {
+ ircd::privmsg_noloop(main_conf_local, main_conf_operchan, "HIGH TRAFFIC WARNING",
+ "Queue depth exceeded @{[main_conf_highqueue]}") if defined(main_conf_operchan);
+ ircd::privmsg_noloop(main_conf_local, main_conf_diag, "HIGH TRAFFIC WARNING",
+ "Queue depth exceeded @{[main_conf_highqueue]}");
+ $last_highqueue = time();
+ }
+
+ if($sync) {
+ message($message);
+ } else {
+ ircd_enqueue($message);
+ }
+}
+
+sub _realcall($$) {
+ no strict 'refs';
+
+ my ($message, $callback) = @_;
+
+ print "Calling ", $callback->{REALCALL}, " ", join(',', @{$message->{ARGS}}), "\n" if DEBUG();
+ local $ircline = $message->{IRCLINE};
+
+ local $SrSv::IRCd::State::synced = $message->{SYNCED}[0]; # XXX This is questionable.
+ local $SrSv::IRCd::State::initial_synced = $message->{SYNCED}[1];
+ local $SrSv::IRCd::State::queue_depth = $message->{QUEUE_DEPTH};
+
+ print "IRCLINE is $ircline synced is $SrSv::IRCd::State::synced initial_synced is $SrSv::IRCd::State::initial_synced\n" if DEBUG();
+
+ &{$callback->{REALCALL}}(@{$message->{ARGS}});
+ ircd::flushmodes() unless $message->{SYNC}; # FIXME
+ print "Finished with $ircline\n" if DEBUG();
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::IRCd::IO;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(ircd_connect ircd_disconnect ircsendimm ircsend ircd_flush_queue) }
+
+use constant {
+ NL => "\015\012",
+};
+
+use Errno ':POSIX';
+use Event;
+
+use SrSv::Process::InParent qw(irc_connect ircsend ircsendimm ircd_flush_queue);
+use SrSv::Process::Worker qw(ima_worker);
+use SrSv::Debug;
+use SrSv::IRCd::State qw($ircline $ircline_real $ircd_ready);
+use SrSv::IRCd::Event qw(callfuncs);
+use SrSv::Unreal::Tokens qw( :tokens );
+use SrSv::IRCd::Parse qw(parse_line);
+use SrSv::RunLevel qw(emerg_shutdown);
+use SrSv::Log qw( write_log );
+
+our $irc_sock;
+our @queue;
+our $flood_queue;
+
+sub irc_error($) {
+ print "IRC connection failed", ($_[0] ? ": $_[0]\n" : ".\n");
+ emerg_shutdown;
+}
+
+{
+ my $partial;
+
+ sub ircrecv {
+ my ($in, $r);
+ while($r = $irc_sock->sysread(my $part, 4096) > 0) {
+ $in .= $part;
+ }
+
+ irc_error($!) if($r <= 0 and not $!{EAGAIN});
+
+ my @lines = split(/\015\012/, $in);
+
+ $lines[0] = $partial . $lines[0];
+ if($in =~ /\015\012$/s) {
+ $partial = '';
+ } else {
+ $partial = pop @lines;
+ }
+
+ foreach my $line (@lines) {
+ $ircline_real++ unless $line =~ /^(?:8|PING)/;
+ write_log('netdump', '', $line) if main::NETDUMP();
+ print ">> $ircline_real $line\n" if DEBUG_ANY;
+ foreach my $ev (parse_line($line)) {
+ next unless $ev;
+
+ callfuncs(@$ev);
+ }
+ }
+ }
+}
+
+{
+ my $watcher;
+
+ sub ircd_connect($$) {
+ my ($remote, $port) = @_;
+
+ print "Connecting..." if DEBUG;
+ $irc_sock = IO::Socket::INET->new(
+ PeerAddr => $remote,
+ PeerPort => $port,
+ Proto => 'tcp',
+ Blocking => 1,
+ ) or die("Could not connect to IRC server ($remote:$port): $!");
+ $irc_sock->blocking(0);
+ print " done\n" if DEBUG;
+
+ $irc_sock->autoflush(1);
+
+ $watcher = Event->io(
+ cb => \&ircrecv,
+ fd => $irc_sock,
+ nice => -1,
+ );
+ }
+
+ sub ircd_disconnect() {
+ ircd_flush_queue();
+ $watcher->cancel;
+ $irc_sock->close;
+ }
+}
+
+sub ircsendimm {
+ print "ircsendimm() ima_worker: ", ima_worker(), "\n" if DEBUG;
+
+ if(defined $flood_queue) {
+ print "FLOOD QUEUE ACTIVE\n" if DEBUG;
+ push @$flood_queue, @_;
+ return;
+ }
+
+ while(my $line = shift @_) {
+ my $r;
+ my $bytes = 0;
+ my $len = length($line) + 2;
+ write_log('netdump', '', split(NL, $line))
+ if main::NETDUMP();
+ while(1) {
+ $r = $irc_sock->syswrite($line . NL, undef, $bytes);
+ $bytes += $r if $r > 0;
+
+ if($r <= 0 or $r < $len) {
+ if($!{EAGAIN} or ($r > 0 and $r < $len)) {
+ # Hold off to avoid flooding off
+ print "FLOOD QUEUE ACTIVE\n" if DEBUG;
+
+ $flood_queue = [];
+
+ push @$flood_queue, substr($line, $bytes) unless $bytes == $len;
+ push @$flood_queue, @_;
+
+ Event->idle (
+ min => 1,
+ max => 10,
+ repeat => 0,
+ cb => \&flush_flood_queue
+ );
+
+ return;
+ } else {
+ irc_error($!);
+ return;
+ }
+ }
+
+ last if($bytes == $len);
+ }
+ print "<< $line\n" if DEBUG_ANY;
+ }
+}
+
+sub ircsend {
+ print "ircsend() ima_worker: ", ima_worker(), "\n" if DEBUG;
+ if(DEBUG) {
+ foreach my $x (@_) {
+ print "<< $ircline $x\n";
+ }
+ }
+
+ if($ircd_ready) {
+ ircsendimm(@_);
+ } else {
+ foreach my $x (@_) {
+ if($x =~ /^@{[TOK_NICK]}/) {
+ unshift @queue, $x;
+ } else {
+ push @queue, $x;
+ }
+ }
+ }
+}
+
+sub ircd_flush_queue() {
+ ircsendimm(@queue);
+ undef @queue;
+}
+
+sub flush_flood_queue() {
+ my $q = $flood_queue;
+ undef $flood_queue;
+ ircsendimm(@$q);
+}
+
+1;
--- /dev/null
+../Unreal/Parse.pm
\ No newline at end of file
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::IRCd::Queue;
+
+# The purpose of this module is to make sure lines get processed in an
+# order that makes sense, e.g., a JOIN should not be processed before
+# the corresponding NICKCONN has been.
+
+# FIXME: This may not be well optimized. It also can be fouled up by
+# conflicting messages with the same WF value, such as the same nick
+# disconnecting and connecting at once.
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(ircd_enqueue queue_size) }
+
+use SrSv::Debug;
+use SrSv::Message qw(message);
+
+our @queue = map [], 0..3; # 3 is the maximum WF value
+
+sub ircd_enqueue($) {
+ my ($message) = @_;
+ my ($ircline, $wf) = @$message{'IRCLINE', 'WF'};
+
+ if($wf == 0) {
+ message($message);
+ return;
+ }
+
+ push @{$queue[$wf]}, $message;
+
+ if(_is_runnable($message)) {
+ print "$message->{IRCLINE} is runnable immediately. (WF=$message->{WF})\n" if DEBUG;
+ message($message);
+ $message->{_Q_RUNNING} = 1;
+ }
+}
+
+sub queue_size() {
+ my $r;
+ foreach (@queue) { $r += @$_ }
+ return $r;
+}
+
+sub finished {
+ my ($message) = @_;
+ my ($ircline, $wf) = @$message{'IRCLINE', 'WF'};
+
+ print "Called finished() for $ircline\n" if DEBUG();
+
+ for(my $i; $i < @{$queue[$wf]}; $i++) {
+ if($queue[$wf][$i]{IRCLINE} == $ircline) {
+ splice(@{$queue[$wf]}, $i, 1);
+ last;
+ }
+ }
+
+ if($message->{TYPE} eq 'SEOS') {
+ $message->{TYPE} = 'POSTSEOS';
+ message($message);
+ }
+
+ _dequeue();
+}
+
+sub _is_runnable($) {
+ my ($message) = @_;
+ my ($ircline, $wf) = @$message{'IRCLINE', 'WF'};
+
+ for(1..($wf-1)) {
+ if(defined($queue[$_][0]) and $queue[$_][0]{IRCLINE} < $ircline) {
+ print "Line $ircline must wait for $queue[$_][0]{IRCLINE}\n" if DEBUG;
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+sub _dequeue {
+ foreach my $q (@queue) {
+ INNER: foreach my $message (@$q) {
+ next INNER if $message->{_Q_RUNNING};
+
+ if(_is_runnable($message)) {
+ print "$message->{IRCLINE} is now runnable\n" if DEBUG;
+
+ message($message);
+ $message->{_Q_RUNNING} = 1;
+ }
+ else {
+ last INNER;
+ }
+ }
+ }
+}
+
+1;
--- /dev/null
+../Unreal/Send.pm
\ No newline at end of file
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::IRCd::State;
+
+
+use strict;
+
+use Exporter 'import';
+our @EXPORT_OK = qw($ircline $ircline_real $remoteserv $ircd_ready synced initial_synced create_server get_server_children set_server_state set_server_juped get_server_state get_online_servers %IRCd_capabilities);
+
+# FIXME - synced() is called very often and should be cached locally
+use SrSv::Process::InParent qw(
+ calc_synced
+ __initial_synced_inparent __synced_inparent
+ create_server get_server_children
+ set_server_state set_server_juped
+ get_server_state get_online_servers);
+
+use SrSv::Conf 'main';
+
+use SrSv::Debug;
+
+use SrSv::Shared qw(%IRCd_capabilities);
+
+our $ircline = 0;
+our $ircline_real = 0;
+our $remoteserv;
+our $ircd_ready;
+
+our %servers;
+our %juped_servers;
+our $synced;
+our $initial_synced;
+our $queue_depth;
+
+sub __initial_synced_inparent {
+ return $initial_synced;
+}
+sub __synced_inparent {
+ return $synced;
+}
+
+sub synced {
+# $ircline is zero if running in a timer context (among other possibilities)
+ return ($ircline ? $synced : __synced_inparent());
+}
+
+sub initial_synced {
+ return ($ircline ? $initial_synced : __synced_inparent());
+}
+
+sub calc_synced {
+ #return ($sync and $sync < $ircd::ircline);
+
+ SYNCED: {
+ foreach my $s (keys(%servers)) {
+ my $state = get_server_state($s);
+
+ print "Server: $s State: $state\n" if DEBUG();
+
+ if(!$state) {
+ $synced = 0;
+ last SYNCED;
+ }
+ }
+
+ $synced = 1;
+ }
+
+ {
+ my $state = get_server_state($remoteserv);
+ if(!$state) {
+ $initial_synced = 0;
+ } else {
+ $initial_synced = 1;
+ }
+ }
+}
+
+sub create_server($$) {
+ my ($child, $parent) = @_;
+
+ $servers{$child} = {
+ PARENT => $parent,
+ CHILDREN => [],
+ SYNCED => 0,
+ NONCONFORMANT => isNonconformant($parent, $child),
+ };
+
+ push @{$servers{$parent}{CHILDREN}}, $child if $parent;
+
+ calc_synced();
+}
+
+sub get_server_children($) {
+ my ($s) = @_;
+ return ($s, map get_server_children($_), @{$servers{$s}{CHILDREN}});
+}
+
+sub set_server_state {
+ my ($server, $state) = @_;
+
+ if(defined($state)) {
+ return if $juped_servers{$server};
+
+ $servers{$server}{SYNCED} = $state;
+ } else {
+ delete $juped_servers{$server};
+
+ if(my $parent = $servers{$server}{PARENT}) {
+ $servers{$parent}{CHILDREN} = [
+ grep {$_ ne $server} @{$servers{$parent}{CHILDREN}}
+ ];
+ }
+
+ foreach (get_server_children($server)) {
+ delete $servers{$_};
+ }
+ }
+
+ calc_synced();
+}
+
+sub set_server_juped($) {
+ my ($server) = @_;
+
+ set_server_state($server, undef);
+ $juped_servers{$server} = 1;
+}
+
+sub isNonconformant(@) {
+ my (@serverList) = @_;
+ foreach my $server (@serverList) {
+ if(defined($servers{$server}) && $servers{$server}->{NONCONFORMANT}) {
+ return 1;
+ }
+ if(defined $main_conf{'unsyncserver'}) {
+ my @list;
+ if(ref($main_conf{'unsyncserver'}) eq 'ARRAY') {
+ @list = @{$main_conf{'unsyncserver'}};
+ } else {
+ @list = ($main_conf{'unsyncserver'});
+ }
+ if(grep (m/^$server$/i, @list) ) {
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+
+sub get_server_state {
+ my ($server) = @_;
+
+ return 1 if isNonconformant($server);
+
+ return $servers{$server}{SYNCED};
+}
+
+sub get_online_servers {
+ my @online_servers;
+ foreach my $server (keys(%servers)) {
+ push @online_servers, $server if $servers{$server}{SYNCED};
+ }
+ return @online_servers;
+}
+
+1;
--- /dev/null
+../Unreal/Validate.pm
\ No newline at end of file
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU Lesser General Public License version 2.1,
+# as published by the Free Software Foundation.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+=cut
+
+THIS CODE IS alpha only, and untested. Don't just trust it blindly.
+
+=cut
+
+package SrSv::Insp::UUID;
+
+use strict;
+use warnings;
+
+
+use Exporter qw( import );
+BEGIN {
+ our @EXPORT = qw( decodeUUID encodeUUID );
+}
+
+use constant {
+ ORD_A => ord('A'),
+ SID_BITS => 24,
+ UID_BITS => 40,
+ CHAR_BITS => 6,
+ CHAR_MASK => 63,
+ # the 24 here is SID_BITS, the 40 is UID_BITS
+ # but you can't reference a constant in a constant.
+ SID_BITMASK => (((2**24)-1) << 40),
+ UID_BITMASK => ~(((2**24)-1) << 40),
+};
+
+sub isAlpha($) {
+ my ($char) = @_;
+ return ($char =~ /^[A-Z]$/);
+}
+sub getBase36($) {
+ my ($char) = @_;
+ if(isAlpha($char)) {
+ return (ord($char) - ORD_A);
+ } else {
+ return int($char) + 26;
+ }
+}
+sub decodeSID(@) {
+ my ($a, $b, $c) = @_;
+ if(length($a) > 1) {
+ ($a, $b, $c) = split(//, $a);
+ }
+ my $sidN = 0;
+ foreach my $char ($a,$b,$c) {
+ $sidN <<= 6;
+ $sidN |= getBase36($char);
+ }
+ return $sidN;
+}
+sub decodeUUID($) {
+ my ($UUID) = @_;
+ my @chars = split(//, $UUID);
+ #my @sidC = @chars[0..2];
+ #my @uidC = @chars[3..8];
+ my $sidN = decodeSID(@chars[0..2]);
+ my $uidN = 0;
+ foreach my $char (@chars[3..8]) {
+ $uidN <<= 6;
+ $uidN |= getBase36($char);
+ }
+ return (($sidN << UID_BITS) | $uidN);
+}
+
+sub encodeChar($) {
+ my ($ch) = @_;
+ if($ch < 26) {
+ $ch = chr(($ch) + ORD_A);
+ } else {
+ $ch -= 26;
+ }
+}
+sub int2chars($$) {
+ my ($id_int, $list) = @_;
+ foreach my $ch (reverse @$list) {
+ $ch = $id_int & CHAR_MASK;
+ $id_int >>= CHAR_BITS;
+ $ch = encodeChar($ch);
+ }
+}
+sub encodeUUID($) {
+ my ($int) = @_;
+ my $SID_int = ($int & (SID_BITMASK)) >> UID_BITS;
+ my $UID_int = $int & UID_BITMASK;
+ my @SID = (0,0,0);
+ int2chars($SID_int, \@SID);
+ my @UID = (0,0,0,0,0,0);
+ int2chars($UID_int, \@UID);
+ print join('', @SID,@UID),"\n";
+}
+
+1;
+
+=cut
+my $int = decodeUUID('751AAAAAA');
+print "$int\n";
+print log($int)/log(2), "\n";
+encodeUUID($int);
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU Lesser General Public License version 2,
+# as published by the Free Software Foundation.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+=cut
+
+THIS CODE IS alpha only, and untested. Don't just trust it blindly.
+
+=cut
+
+use strict;
+use warnings;
+
+sub isAlpha($) {
+ my ($char) = @_;
+ return ($char =~ /[A-Z]/);
+}
+
+sub getBase36($) {
+ my ($char) = @_;
+ if(isAlpha($char)) {
+ my $val = (ord($char) - ord('A')) + 10;
+ #print "$val\n";
+ return $val;
+ } else {
+ return int($char);
+ }
+}
+
+sub decodeUUID($) {
+ my ($UUID) = @_;
+ my @chars = split(//, $UUID);
+ my @sidC = @chars[0..2];
+ my @uidC = @chars[3..8];
+ my $sidN = int($sidC[0]) << (4 + (6 * 2));
+ $sidN |= getBase36($sidC[1]) << (4 + (6 * 1));
+ $sidN |= getBase36($sidC[2]) << (4 + (6 * 0));
+ my $uidN = 0;
+ foreach my $char (@uidC) {
+ #print "$char\n";
+ $uidN <<= 6;
+ $uidN |= getBase36($char);
+ }
+ return (($sidN << 48) | $uidN);
+}
+
+my $int = decodeUUID('751AAAAAA');
+print "$int\n";
+print log($int)/log(2), "\n";
--- /dev/null
+#!/usr/bin/perl
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU Lesser General Public License version 2.1,
+# as published by the Free Software Foundation.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+=cut
+
+THIS CODE IS alpha only, and untested. Don't just trust it blindly.
+
+=cut
+
+use strict;
+use warnings;
+# the next 2 lines are temp, you should use the 3rd.
+use UUID;
+import SrSv::Insp::UUID qw( decodeUUID encodeUUID );
+#use SrSv::Insp::UUID;
+
+my $int = decodeUUID('751AAAAAA');
+print "$int\n";
+print log($int)/log(2), "\n";
+encodeUUID($int);
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package SrSv::Log;
+
+use strict;
+use IO::Handle;
+use English qw(-no_match_var);
+
+use SrSv::Debug;
+use SrSv::Timer qw(add_timer);
+use SrSv::Time;
+use SrSv::Process::InParent qw(write_log open_log close_log rotate_logs close_all_logs);
+use IO::File;
+
+use SrSv::Text::Codes qw( strip_codes );
+
+use SrSv::Conf2Consts qw(main);
+
+use Exporter 'import';
+BEGIN {
+ my %constants = (
+ LOG_DEBUG => 0,
+ LOG_INFO => 1,
+ LOG_WARNING => 2, # A bad thing might happen
+ LOG_ERROR => 3, # A bad thing happened
+ LOG_CRITICAL => 4, # One module is going down
+ LOG_FATAL => 5, # One thread is going down
+ LOG_PANIC => 6, # The entire server is going down
+
+ LOG_OPEN => 1,
+ LOG_CLOSE => 2,
+ LOG_WRITE => 3,
+ LOG_ROTATE => 4,
+ );
+
+ require constant; import constant (\%constants);
+ our @EXPORT = ( qw( wlog write_log open_log close_log ), keys(%constants) );
+ our @EXPORT_OK = ( qw ( rotate_logs close_all_logs ) );
+ our %EXPORT_TAGS = (
+ levels => [keys(%constants)],
+ all => [@EXPORT, @EXPORT_OK],
+ );
+}
+
+our $path = './logs';
+our @levels = ('DEBUG', 'INFO', 'WARNING', 'ERROR', 'CRITICAL', 'FATAL', 'PANIC');
+
+open_log('diag', 'services.log');
+open_log('netdump', 'netdump.log') if main::NETDUMP();
+
+sub wlog($$$) {
+ my ($service, $level, $text) = @_;
+
+ my $prefix;
+ $prefix = "\002\00304" if($level > LOG_INFO);
+ $prefix .= $levels[$level];
+ ircd::privmsg($main::rsnick, main_conf_diag, "$prefix\: ($service) $text");
+ write_log('diag', '<'.$main::rsnick.'>', "$prefix\: ($service) $text");
+}
+
+my %log_handles;
+my %file_handles;
+
+sub write_log($$@) {
+ my ($handle, $prefix, @payloads) = @_;
+ unless (defined($log_handles{lc $handle})) {
+ ircd::debug_nolog("undefined log-handle $handle, aborting write()") if main::DEBUG();
+ return undef;
+ }
+ foreach (@payloads) {
+ $_ = strip_codes($_);
+ }
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime();
+ my $time = sprintf("%02d:%02d:%02d", $hour, $min, $sec);
+ my $payload = $time.$prefix.' '.join("\n".$time.$prefix.' ', @payloads);
+ print {$log_handles{lc $handle}} "$payload\n";
+}
+
+sub open_log($$) {
+ my ($handle, $filename) = @_;
+ if (defined($log_handles{lc $handle})) {
+ ircd::debug_nolog("duplicate log-handle $handle, aborting open()");
+ return undef;
+ }
+ my ($year, $month, undef, $mday) = gmt_date();
+ my $filename2 = $filename.'-'.sprintf('%04d-%02d-%02d', $year, $month, $mday);
+
+ my $fh;
+ if($fh = IO::File->new($path.'/'.$filename2, '>>')) {
+ } else {
+ use SrSv::RunLevel qw( main_shutdown );
+ ircd::debug_nolog(qq(Unable to open "$path/$filename2": $OS_ERROR}));
+ main_shutdown();
+ }
+ $fh->autoflush(1);
+ $log_handles{lc $handle} = $fh;
+ $file_handles{lc $handle} = { BASENAME => $filename, FILENAME => $filename2 };
+}
+
+sub close_log($) {
+ my ($handle) = @_;
+ unless (defined($log_handles{lc $handle})) {
+ ircd::debug_nolog("undefined log-handle $handle, aborting close()");
+ return undef;
+ }
+ $log_handles{lc $handle}->close();
+ delete($log_handles{lc $handle});
+ delete($log_handles{lc $handle});
+}
+
+sub rotate_logs() {
+ foreach my $handle (keys(%file_handles)) {
+ $log_handles{lc $handle}->close();
+ my ($year, $month, undef, $mday) = gmt_date();
+ $file_handles{lc $handle}{FILENAME} =
+ $file_handles{lc $handle}{BASENAME}.'-'.sprintf('%04d-%02d-%02d', $year, $month, $mday);
+ my $new_fh;
+ if($new_fh = IO::File->new($path.'/'.$file_handles{lc $handle}{FILENAME}, '>>')) {
+ } else {
+ use SrSv::RunLevel qw( main_shutdown );
+ my $new_path = "$path/".$file_handles{lc $handle}{FILENAME};
+ ircd::debug_nolog(qq(Unable to open "$new_path": $OS_ERROR}));
+ main_shutdown();
+ }
+ $log_handles{lc $handle} = $new_fh;
+ }
+
+ #add_timer('', get_nextday_time()-time(), __PACKAGE__, 'SrSv::Log::rotate_logs');
+ Event->timer( at => get_nextday_time(), cb => \&SrSv::Log::rotate_logs );
+}
+
+sub close_all_logs() {
+ foreach my $handle (keys(%file_handles)) {
+ close_log($handle);
+ }
+}
+
+# set a timer to rotate logs on day-change
+Event->timer( at => get_nextday_time(), cb => \&SrSv::Log::rotate_logs );
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Message;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(add_callback message call_callback unit_finished current_message) }
+
+use Carp;
+use Storable qw(fd_retrieve store_fd);
+
+use SrSv::Debug;
+BEGIN {
+ if(DEBUG) {
+ require Data::Dumper; import Data::Dumper ();
+ }
+}
+
+use SrSv::Process::Call qw(safe_call);
+use SrSv::Process::Worker qw(ima_worker get_socket multi call_in_parent call_all_child do_callback_in_child);
+
+our %callbacks_by_trigger_class;
+our %callbacks_by_after;
+our %callbacks_by_name;
+
+our $current_message;
+
+### Public functions
+
+sub add_callback($) {
+ my ($callback) = @_;
+
+ if(multi) {
+ croak "Callbacks cannot be added at runtime";
+ }
+
+ if(my $after = $callback->{AFTER}) {
+ push @{$callbacks_by_after{$after}}, $callback;
+ }
+
+ $callback->{NAME} = $callback->{CALL} unless $callback->{NAME};
+ if(my $name = $callback->{NAME}) {
+ push @{$callbacks_by_name{$name}}, $callback;
+ }
+
+ if(my $trigger = $callback->{TRIGGER_COND}{CLASS}) {
+ push @{$callbacks_by_trigger_class{$trigger}}, $callback;
+ }
+
+ if(DEBUG()) {
+ print "Added callback: $callback->{NAME}\n";
+ }
+}
+
+sub message($) {
+ my ($message) = @_;
+
+ if(ima_worker()) {
+ if($message->{SYNC}) {
+ print "Triggered a sync callback!\n" if DEBUG();
+ trigger_callbacks($message);
+ } else {
+ store_fd($message, get_socket());
+ fd_retrieve(get_socket());
+ }
+ return;
+ }
+
+ trigger_callbacks($message);
+}
+
+### Semi-private ###
+
+sub call_callback {
+ my ($callback, $message) = @_;
+
+ local $current_message = $message;
+
+ if(my $call = $callback->{CALL}) {
+ safe_call($call, [$message, $callback]);
+ }
+}
+
+sub unit_finished($$) {
+ my ($callback, $message) = @_;
+
+ if(DEBUG()) {
+ print "--- Finished unit\nCallback: $callback->{NAME}\nMessage: $message->{CLASS}\n";
+ }
+
+ safe_call($callback->{ON_FINISH}, [$callback, $message]) if $callback->{ON_FINISH};
+
+ $message->{_CB_COUNTDOWN}--;
+ print "_CB_COUNTDOWN is $message->{_CB_COUNTDOWN}\n---\n" if DEBUG;
+
+ $message->{_CB_DONE}{$callback->{NAME}} = 1;
+
+ if(!$message->{SYNC} and defined($message->{_CB_QUEUE}) and @{$message->{_CB_QUEUE}}) {
+ trigger_callbacks($message);
+ }
+
+ if($message->{_CB_COUNTDOWN} == 0) {
+ message_finished($message);
+ }
+}
+
+sub message_finished($) {
+ my ($message) = @_;
+
+ print "Message finished: $message->{CLASS}\n" if DEBUG;
+
+ for(qw(_CB_QUEUE _CB_COUNTDOWN _CB_DONE _CB_TODO)) {
+ undef $message->{$_};
+ }
+
+ safe_call($message->{ON_FINISH}, [$message]) if $message->{ON_FINISH};
+}
+
+### Private functions ###
+
+sub trigger_callbacks($) {
+ my ($message) = @_;
+
+ my $callbacks;
+
+ if(defined($message->{_CB_QUEUE})) {
+ $callbacks = $message->{_CB_QUEUE};
+ } else {
+ $callbacks = get_matching_callbacks($message);
+ }
+
+ if(@$callbacks) {
+ $message->{_CB_COUNTDOWN} = @$callbacks unless defined($message->{_CB_COUNTDOWN});
+
+ my $do_next = [];
+
+ foreach my $callback (@$callbacks) {
+ my $after = $callback->{AFTER};
+ if($after and $message->{_CB_TODO}{$after} and not $message->{_CB_DONE}{$after}) {
+ push @$do_next, $callback;
+ } else {
+ do_unit($callback, $message);
+ }
+ }
+
+ $message->{_CB_QUEUE} = $do_next;
+
+ goto &trigger_callbacks if($message->{SYNC} and @$do_next > 0);
+ }
+
+ else {
+ if(DEBUG) {
+ print "Message with no callbacks: ".Dumper($message);
+ }
+
+ message_finished($message);
+ }
+}
+
+sub do_unit($$) {
+ my ($callback, $message) = @_;
+
+ if(!multi or $callback->{PARENTONLY} or $message->{SYNC}) {
+ call_callback($callback, $message);
+ unit_finished($callback, $message);
+ } else {
+ do_callback_in_child($callback, $message);
+ }
+}
+
+sub get_matching_callbacks($) {
+ my ($message) = @_;
+ my $ret = [];
+
+ my $class = $message->{CLASS};
+
+ foreach my $callback (@{$callbacks_by_trigger_class{$class}}) {
+ if(callback_matches($message, $callback)) {
+ push @$ret, $callback;
+ $message->{_CB_TODO}{$callback->{NAME}} = 1;
+ }
+ }
+
+ return $ret;
+}
+
+sub callback_matches($$) {
+ my ($message, $callback) = @_;
+
+ foreach my $cond (keys(%{$callback->{TRIGGER_COND}})) {
+ if(ref($callback->{TRIGGER_COND}{$cond}) eq 'Regexp') {
+ return 0 if defined($message->{$cond}) && !($message->{$cond} =~ $callback->{TRIGGER_COND}{$cond});
+ } else {
+ return 0 if defined($message->{$cond}) && !(lc $message->{$cond} eq lc $callback->{TRIGGER_COND}{$cond});
+ }
+ }
+
+ return 1;
+}
+
+sub current_message() { return $current_message }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::MySQL;
+
+use strict;
+
+use DBI qw( :sql_types );
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT_OK = (qw( $dbh connectDB disconnectDB ), @{$DBI::EXPORT_TAGS{'sql_types'}} );
+ our %EXPORT_TAGS = ( sql_types => $DBI::EXPORT_TAGS{'sql_types'} );
+}
+
+use SrSv::Process::Init;
+
+use SrSv::Conf::sql;
+
+use SrSv::Conf 'sql';
+
+our $dbh;
+
+proc_init {
+ connectDB();
+};
+sub connectDB() {
+ $dbh = DBI->connect(
+ "DBI:mysql:".$sql_conf{'mysql-db'}.($sql_conf{server_prepare} ? ":mysql_server_prepare=1" : ''),
+ $sql_conf{'mysql-user'},
+ $sql_conf{'mysql-pass'},
+ {
+ AutoCommit => 1,
+ RaiseError => 0,
+ mysql_auto_reconnect => 1,
+ }
+ );
+ # Prevent timeout
+ $dbh->do("SET wait_timeout=(86400*365)");
+}
+
+sub disconnectDB() {
+ $dbh->disconnect();
+ $dbh = undef;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::MySQL::Glob;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw( glob2sql sql2glob ) }
+
+sub glob2sql(@) {
+ foreach (@_) {
+ s/([%_])/\\$1/g;
+ tr/*?/%_/;
+ }
+ return (wantarray ? @_ : $_[0]);
+}
+
+sub sql2glob(@) {
+ foreach (@_) {
+ s/(?<!\\)_/?/g;
+ s/(?<!\\)%/*/g;
+ s/\\([%_])/$1/g;
+ }
+ return (wantarray ? @_ : $_[0]);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::MySQL::KeyValStub;
+
+use strict;
+
+use Symbol 'delete_package';
+
+use SrSv::MySQL '$dbh';
+use SrSv::Process::Init;
+
+sub create_stub($$) {
+ my ($get_sql, $set_sql) = @_;
+
+ my ($get, $set);
+
+ proc_init {
+ $get = $dbh->prepare($get_sql);
+ $set = $dbh->prepare($set_sql);
+ };
+
+ return sub ($;$) {
+ my ($k, $v) = @_;
+
+ if(defined($v)) {
+ $set->execute($v, $k); $set->finish;
+ } else {
+ $get->execute($k);
+ $v = $get->fetchrow_array;
+ $get->finish;
+ }
+
+ return $v;
+ };
+}
+
+sub create_readonly_stub($) {
+ my ($get_sql) = @_;
+
+ my ($get);
+
+ proc_init {
+ $get = $dbh->prepare($get_sql);
+ };
+
+ return sub ($) {
+ my ($k) = @_;
+
+ $get->execute($k);
+ my $v = $get->fetchrow_array;
+ $get->finish;
+
+ return $v;
+ };
+}
+
+sub import {
+ my (undef, $stubs) = @_;
+
+ my $callpkg = caller();
+
+ while(my ($name, $sql) = each %$stubs) {
+ no strict 'refs';
+
+ my $stub;
+
+ if(@$sql == 2) {
+ $stub = create_stub($sql->[0], $sql->[1]);
+ }
+ elsif(@$sql == 1) {
+ $stub = create_readonly_stub($sql->[0]);
+ }
+ else {
+ my ($package, $filename, $line) = caller();
+ die "Invalid use of ".__PACKAGE__." at $filename line $line\n";
+ }
+
+ *{"$callpkg\::$name"} = $stub;
+ }
+}
+
+INIT {
+ delete_package(__PACKAGE__);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::MySQL::Stub;
+
+=head1 NAME
+
+SrSv::MySQL::Stub - Create functions for SQL queries
+
+=cut
+
+use strict;
+
+use Symbol 'delete_package';
+use Carp qw( confess );
+
+use SrSv::Debug;
+use SrSv::MySQL qw( $dbh :sql_types );
+use SrSv::Process::Init;
+
+our %types;
+
+sub create_null_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+ };
+
+ return sub {
+ my $ret;
+ eval { $ret = $sth->execute(@_) + 0; }; #force result to be a number
+ if($@) { confess($@) }
+ $sth->finish();
+ return $ret;
+ };
+}
+
+sub create_insert_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+ # This is potentially interesting here,
+ # given a INSERT SELECT
+ if($stub->{SQL} =~ /OFFSET \?$/) {
+ my @dummy = $stub->{SQL} =~ /\?/g;
+ $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
+ }
+ };
+
+ return sub {
+ eval { $sth->execute(@_) + 0 }; #force result to be a number
+ if($@) { confess($@) }
+ $sth->finish();
+ return $dbh->last_insert_id(undef, undef, undef, undef);;
+ };
+}
+
+sub create_scalar_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+ if($stub->{SQL} =~ /OFFSET \?$/) {
+ my @dummy = $stub->{SQL} =~ /\?/g;
+ $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
+ }
+ };
+
+ return sub {
+ eval{ $sth->execute(@_); };
+ if($@) { confess($@) }
+ my $scalar;
+ eval{ ($scalar) = $sth->fetchrow_array; };
+ if($@) { confess($@) }
+ $sth->finish();
+ return $scalar;
+ };
+}
+
+sub create_arrayref_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+ if($stub->{SQL} =~ /OFFSET \?$/) {
+ my @dummy = $stub->{SQL} =~ /\?/g;
+ $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
+ }
+ };
+
+ return sub {
+ eval{ $sth->execute(@_); };
+ if($@) { confess($@) }
+ return $sth->fetchall_arrayref;
+ };
+}
+
+sub create_array_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+ if($stub->{SQL} =~ /OFFSET \?$/) {
+ my @dummy = $stub->{SQL} =~ /\?/g;
+ $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
+ }
+ };
+
+ return sub {
+ eval{ $sth->execute(@_); };
+ if($@) { confess($@) }
+ my $arrayRef;
+ eval{ $arrayRef = $sth->fetchall_arrayref; };
+ if($@) { confess($@) }
+ $sth->finish();
+ return @$arrayRef;
+ };
+}
+
+sub create_column_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+=cut
+# This isn't useful here.
+ if($stub->{SQL} =~ /OFFSET \?$/) {
+ my @dummy = $stub->{SQL} =~ /\?/g;
+ $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
+ }
+=cut
+ };
+
+ return sub {
+ eval{ $sth->execute(@_); };
+ if($@) { confess($@) }
+ my $arrayRef;
+ eval { $arrayRef = $sth->fetchall_arrayref; };
+ if($@) { confess($@) }
+ $sth->finish();
+ return map({ $_->[0] } @$arrayRef);
+ };
+}
+
+sub create_row_stub($) {
+ my ($stub) = @_;
+
+ my $sth;
+
+ proc_init {
+ $sth = $dbh->prepare($stub->{SQL});
+ if($stub->{SQL} =~ /OFFSET \?$/) {
+ my @dummy = $stub->{SQL} =~ /\?/g;
+ $sth->bind_param(scalar(@dummy), 0, SQL_INTEGER);
+ }
+ };
+
+ return sub {
+ $sth->execute(@_);
+ my @row = $sth->fetchrow_array;
+ $sth->finish();
+ return @row;
+ };
+}
+
+BEGIN {
+ %types = (
+ NULL => \&create_null_stub,
+ SCALAR => \&create_scalar_stub,
+ ARRAYREF => \&create_arrayref_stub,
+
+ ARRAY => \&create_array_stub,
+ ROW => \&create_row_stub,
+ COLUMN => \&create_column_stub,
+ INSERT => \&create_insert_stub,
+ );
+}
+
+sub export_stub($$$) {
+ my ($name, $proto, $code) = @_;
+
+ no strict 'refs';
+
+ *{$name} = eval "sub $proto { goto &\$code }";
+}
+
+sub import {
+ my (undef, $ins) = @_;
+
+ while(my ($name, $args) = each %$ins) {
+ my $stub = {
+ NAME => $name,
+ TYPE => $args->[0],
+ SQL => $args->[1],
+ };
+
+ my @params = $stub->{SQL} =~ /\?/g;
+
+ $stub->{PROTO} = '(' . ('$' x @params) . ')';
+ print "$stub->{NAME} $stub->{PROTO}\n" if DEBUG;
+
+ export_stub scalar(caller) . '::' . $stub->{NAME}, $stub->{PROTO}, $types{$stub->{TYPE}}->($stub);
+ }
+}
+
+1;
+
+=head1 SYNOPSIS
+
+ use SrSv::MySQL::Stub {
+ get_all_foo => ['ARRAYREF', "SELECT * FROM foo"],
+ is_foo_valid => ['SCALAR', "SELECT 1 FROM foo WHERE id=? AND valid=1"],
+ delete_foo => ['NULL', "DELETE FROM foo WHERE id=?"],
+
+ get_all_foo_array => ['ARRAY', "SELECT * FROM foo"],
+ get_column_foo => ['COLUMN', "SELECT col FROM foo"],
+ get_row_foo => ['ROW', "SELECT * FROM foo LIMIT 1"],
+ insert_foo > ['INSERT', "INSERT INTO foo (foo,bar) VALUES (?,?)"],
+ };
+
+=head1 DESCRIPTION
+
+This module is a convenient way to make lots of subroutines that execute
+SQL statements.
+
+=head1 USAGE
+
+ my @listOfListrefs = get_all_foo_array(...);
+ my $listrefOfListrefs = get_all_foo(...);
+ my $scalar = is_foo_valid(...);
+ my $success = delete_foo(...);
+
+type ARRAYREF is for legacy code only, I doubt anyone will want to use
+it for new code. ARRAY returns a list of listrefs, while ARRAYREF
+returns a listref of listrefs.
+
+NULL returns success or failure. Technically, number of columns
+affected. Thus sometimes it may not have FAILED, but as it had no
+effect, it will return zero.
+
+INSERT returns the last INSERT ID in the current execution context. This
+basically means that if your table has a PRIMARY KEY AUTO_INCREMENT, it
+will return the value of that primary key.
+
+COLUMN returns a list consisting of a single column (the first, if there
+are more than one in the SELECT).
+
+ROW is like column, but returns an array of only a single row.
+
+=cut
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::MySQL::Unlock;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw($unlock_tables) }
+
+use SrSv::Process::Init;
+use SrSv::MySQL '$dbh';
+
+our ($unlock_tables);
+
+proc_init {
+ $unlock_tables = $dbh->prepare("UNLOCK TABLES");
+};
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::NickControl::Enforcer;
+
+=head1 NAME
+
+SrSv::NickControl::Enforcer - Prevent users from using nicks without identifying.
+
+=head1 SYNOPSIS
+
+ use SrSv::NickControl::Enforcer qw(%enforcers);
+
+=head1 DESCRIPTION
+
+At the moment, this is just a place to put the %enforcers hash.
+
+=cut
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(%enforcers) }
+
+use SrSv::Shared qw(%enforcers);
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::NickReg::Flags;
+
+use strict;
+
+use Exporter 'import';
+
+BEGIN {
+ my %constants = (
+ # current nickreg.flags definition limits us to 16 of these. or 32768 as last flag
+ NRF_HIDEMAIL => 1,
+ NRF_NOMEMO => 2,
+ NRF_NOACC => 4,
+ NRF_NEVEROP => 8,
+ NRF_AUTH => 16,
+ NRF_HOLD => 32,
+ NRF_FREEZE => 64,
+ NRF_VACATION => 128,
+ NRF_EMAILREG => 256,
+ NRF_NOHIGHLIGHT => 512,
+ NRF_SENDPASS => 1024,
+ );
+
+ our @EXPORT = (qw(nr_set_flag nr_set_flags nr_chk_flag nr_chk_flag_user nr_get_flags), keys(%constants));
+
+ require constant; import constant (\%constants);
+}
+
+use SrSv::Process::Init;
+use SrSv::MySQL '$dbh';
+
+use SrSv::User qw(get_user_id);
+
+our ($get_flags, $set_flag, $unset_flag, $set_flags, $get_nickreg_flags_user);
+
+proc_init {
+ $get_flags = $dbh->prepare("SELECT nickreg.flags FROM nickreg, nickalias WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+ $set_flag = $dbh->prepare("UPDATE nickreg, nickalias SET nickreg.flags=(nickreg.flags | (?)) WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+ $set_flags = $dbh->prepare("UPDATE nickreg, nickalias SET nickreg.flags=? WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+ $unset_flag = $dbh->prepare("UPDATE nickreg, nickalias SET nickreg.flags=(nickreg.flags & ~(?)) WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+ $get_nickreg_flags_user = $dbh->prepare("SELECT BIT_OR(nickreg.flags) FROM user
+ JOIN nickid ON (user.id=nickid.id)
+ JOIN nickreg ON(nickid.nrid=nickreg.id)
+ WHERE user.id=? GROUP BY user.id");
+};
+
+sub nr_set_flag($$;$) {
+ my ($nick, $flag, $sign) = @_;
+ $sign = 1 unless defined($sign);
+
+ if($sign) {
+ $set_flag->execute($flag, $nick);
+ } else {
+ $unset_flag->execute($flag, $nick);
+ }
+}
+
+sub nr_set_flags($$) {
+ my ($nick, $flags) = @_;
+
+ $set_flags->execute($flags, $nick);
+}
+
+sub nr_chk_flag($$;$) {
+ my ($nick, $flag, $sign) = @_;
+ $sign = 1 unless defined($sign);
+
+ $get_flags->execute($nick);
+ my ($flags) = $get_flags->fetchrow_array;
+
+ return ($sign ? ($flags & $flag) : !($flags & $flag));
+}
+
+sub nr_chk_flag_user($$;$) {
+ my ($tuser, $flag, $sign) = @_;
+ $sign = 1 unless defined($sign);
+
+ my $flags = 0;
+ # This needs to have ns_identify, ns_logout and ns_set clear $user->{NICKFLAGS}
+ if(exists $tuser->{NICKFLAGS}) {
+ $flags = $tuser->{NICKFLAGS};
+ }
+ else {
+ $get_nickreg_flags_user->execute(get_user_id($tuser));
+ ($flags) = $get_nickreg_flags_user->fetchrow_array();
+ $get_nickreg_flags_user->finish();
+ $tuser->{NICKFLAGS} = $flags;
+ }
+
+ return ($sign ? ($flags & $flag) : !($flags & $flag));
+}
+
+sub nr_get_flags($) {
+ my ($nick) = @_;
+
+ $get_flags->execute($nick);
+ my ($flags) = $get_flags->fetchrow_array(); $get_flags->finish();
+ return $flags;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::NickReg::NickText;
+
+use strict;
+
+use Exporter 'import';
+
+BEGIN {
+ my %constants = (
+ NTF_QUIT => 1,
+ NTF_GREET => 2,
+ NTF_JOIN => 3,
+ NTF_AUTH => 4,
+ NTF_UMODE => 5,
+ NTF_VACATION => 6,
+ NTF_AUTHCODE => 7,
+ NTF_PROFILE => 8,
+ NTF_VHOST_REQ => 9,
+ );
+ require constant; import constant \%constants;
+ our @EXPORT = keys(%constants);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::NickReg::User;
+
+=head1 NAME
+
+SrSv::NickReg::User - Determine which users are identified to which nicks
+
+=cut
+
+use strict;
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT_OK = qw(
+ is_identified chk_identified
+ get_id_nicks
+ get_nick_user_nicks get_nick_users get_nick_users_all
+ );
+}
+
+use SrSv::Process::Init;
+use SrSv::MySQL '$dbh';
+use SrSv::User qw(:flags get_user_nick get_user_id);
+use SrSv::User::Notice;
+use SrSv::NickReg::Flags;
+use SrSv::Errors;
+
+my $find_user_tables = 'user JOIN nickid ON (user.id=nickid.id) JOIN nickalias ON (nickid.nrid=nickalias.nrid)';
+require SrSv::MySQL::Stub;
+import SrSv::MySQL::Stub {
+ __get_nick_users => ['ARRAY', "SELECT user.nick, user.id
+ FROM $find_user_tables WHERE nickalias.alias=? AND user.online=1"],
+ __get_nick_users_all => ['ARRAY', "SELECT user.nick, user.id, user.online
+ FROM $find_user_tables WHERE nickalias.alias=?"],
+ __is_identified => ['SCALAR', "SELECT 1
+ FROM $find_user_tables WHERE user.nick=? AND nickalias.alias=?"],
+ __get_id_nicks => ['COLUMN', "SELECT nickreg.nick
+ FROM nickid JOIN nickreg ON (nickid.nrid=nickreg.id) WHERE nickid.id=?"],
+};
+
+sub is_identified($$) {
+ my ($user, $rnick) = @_;
+ my $nick = get_user_nick($user);
+
+ return __is_identified($nick, $rnick) ? 1 : 0;
+}
+
+sub chk_identified($;$) {
+ my ($user, $nick) = @_;
+
+ $nick = get_user_nick($user) unless $nick;
+
+ nickserv::chk_registered($user, $nick) or return 0;
+
+ unless(is_identified($user, $nick)) {
+ notice($user, $err_deny);
+ return 0;
+ }
+
+ return 1;
+}
+
+sub get_id_nicks($) {
+ my ($user) = @_;
+ my $id = get_user_id($user);
+
+ return __get_id_nicks($id);
+}
+
+sub get_nick_user_nicks($) {
+ my ($nick) = @_;
+
+ return map $_->[0], __get_nick_users($nick);
+}
+
+sub get_nick_users($) {
+ my ($nick) = @_;
+
+ return map +{ NICK => $_->[0], ID => $_->[1], ONLINE => 1 }, __get_nick_users($nick);
+}
+
+sub get_nick_users_all($) {
+ my ($nick) = @_;
+
+ return map +{ NICK => $_->[0], ID => $_->[1], ONLINE => $_->[2] }, __get_nick_users_all($nick);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::OnIRC;
+
+use strict;
+
+BEGIN {
+ our @ISA = qw(Exporter);
+ our @EXPORT = qw(IRC_SERVER);
+}
+
+sub import {
+ my ($pkg, $is_server) = @_;
+
+ if($is_server) {
+ *IRC_SERVER = sub () { 1 };
+ }
+ elsif(not defined *IRC_SERVER{CODE}) {
+ *IRC_SERVER = sub () { 0 };
+ }
+
+ SrSv::OnIRC->export_to_level(1);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Process::Call;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(safe_call) }
+
+use Carp 'longmess';
+
+sub safe_call($$) {
+ my ($call, $parms) = @_;
+ my $wa = wantarray;
+ my $ret;
+
+ eval {
+ no strict 'refs';
+
+ local $SIG{__WARN__} = sub {
+ ircd::debug(" -- Warning: ".$_[0],
+ ($_[0] =~ /MySQL\/Stub/ ? split(/\n/, Carp::longmess($@)) : undef ) );
+ };
+
+ local $SIG{__DIE__} = sub {
+ ($_[0] =~ /^user/) or
+ ircd::debug(" --", "-- DIED: ".$_[0], split(/\n/, Carp::longmess($@)), " --");
+ };
+
+
+ if(not defined($wa)) {
+ &$call(@$parms);
+ }
+ elsif(not $wa) {
+ $$ret = &$call(@$parms);
+ }
+ else {
+ @$ret = &$call(@$parms);
+ }
+ };
+ return undef if $@;
+
+ if(not defined($wa)) {
+ return;
+ }
+ elsif(not $wa) {
+ return $$ret;
+ }
+ else {
+ return @$ret;
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Process::InParent;
+
+use strict;
+
+use Filter::Util::Call;
+
+use SrSv::Debug;
+use SrSv::Process::Worker qw($ima_worker);
+
+sub import {
+ my $class = shift;
+ my ($package) = caller;
+
+ my $expr = join('|', @_);
+ filter_add( sub {
+ my $status;
+
+ s/^sub ($expr)(\W|$)/sub $1\_INPARENT$2/ if ($status = filter_read()) > 0;
+ print "Filtered: $_" if DEBUG() and $1;
+
+ return $status;
+ });
+
+ my @subs = map { "$package\::$_" } @_;
+
+ foreach my $sub (@subs) {
+ no strict 'refs';
+ no warnings;
+
+ print "Installing stub for $sub\n" if DEBUG();
+ *{$sub} = _make_stub($sub);
+ }
+}
+
+sub _make_stub($) {
+ my ($fake_sub) = @_;
+ my $real_sub = \&{"$fake_sub\_INPARENT"};
+
+ return sub {
+ if($ima_worker) {
+ print "Called $fake_sub in child.\n" if DEBUG();
+ SrSv::Process::Worker::call_in_parent($fake_sub, @_);
+ } else {
+ print "Called $fake_sub in parent.\n" if DEBUG();
+ goto &$real_sub;
+ }
+ };
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Process::Init;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw(proc_init) }
+
+use SrSv::OnIRC;
+
+our @subs;
+
+sub proc_init(&) {
+ if(IRC_SERVER) {
+ push @subs, $_[0];
+ } else {
+ &{$_[0]}();
+ }
+}
+
+sub do_init {
+ foreach my $sub (@subs) {
+ &$sub;
+ }
+
+ @subs = ();
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Process::Worker;
+
+use strict;
+
+use Carp 'croak';
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT_OK = qw(spawn write_pidfiles
+ ima_worker $ima_worker
+ multi get_socket
+ call_in_parent call_all_child do_callback_in_child
+ shutdown_worker shutdown_all_workers kill_all_workers)
+ }
+
+use Event;
+use English qw( -no_match_vars );
+use IO::Socket;
+use IO::File;
+use Storable qw(fd_retrieve store_fd);
+
+use SrSv::Debug;
+
+sub PREFIX() { return main::PREFIX }
+
+BEGIN {
+ if(DEBUG) {
+ require Data::Dumper; import Data::Dumper ();
+ }
+}
+
+use SrSv::Message qw(message call_callback unit_finished);
+use SrSv::Process::Call qw(safe_call);
+use SrSv::RunLevel qw(:levels $runlevel);
+
+use SrSv::Process::InParent qw(shutdown_worker shutdown_all_workers kill_all_workers);
+
+use SrSv::Process::Init ();
+
+our $parent_sock;
+our $multi = 0;
+our @workers;
+our @free_workers;
+our @queue;
+
+our $ima_worker = 0;
+
+### Public interface ###
+
+sub spawn() {
+ $multi = 1;
+
+ my ($parent, $child) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+
+ if(my $pid = fork()) {
+ my $worker = {
+ SOCKET => $child,
+ NUMBER => scalar(@workers),
+ PID => $pid,
+ };
+
+ my $nr = @workers;
+ push @workers, $worker;
+ $worker->{WATCHER} = Event->io (
+ cb => \&SrSv::Process::Worker::req_from_child,
+ fd => $child,
+ data => $nr,
+ );
+ } else {
+ loop($parent);
+ exit;
+ }
+}
+
+sub write_pidfiles() {
+ my $fh = IO::File->new("@{[PREFIX]}/data/worker.pids", 'w', '0600');
+ for(my $i = scalar(@workers); $i; $i--) {
+ my $pid = $workers[$i-1]->{PID};
+ print $fh $pid,"\n";
+ }
+ print $fh $PID,"\n";
+}
+
+sub ima_worker {
+ return $ima_worker;
+}
+
+sub multi {
+ return $multi;
+}
+
+sub get_socket {
+ if(ima_worker) {
+ return $parent_sock;
+ }
+}
+
+sub call_in_parent(@) {
+ my ($f, @args) = @_;
+ if(!ima_worker) {
+ no strict 'refs';
+ return &$f(@args);
+ }
+
+ my %call = (
+ CLASS => 'CALL',
+ FUNCTION => $f,
+ ARGS => \@args
+ );
+
+ store_fd(\%call, $parent_sock);
+
+ if(wantarray) {
+ return @{ fd_retrieve($parent_sock) };
+ } else {
+ return @{ fd_retrieve($parent_sock) }[-1];
+ }
+}
+
+sub call_all_child(@) {
+ croak "call_all_child is not functional.\n";
+
+=for comment
+ my (@args) = @_;
+
+ foreach my $worker (@workers) {
+ store_fd(\@args, $worker->{SOCKET});
+ }
+=cut
+}
+
+{
+ my $callback;
+
+ sub shutdown_worker($) {
+ my $worker = shift;
+
+ print "Shutting down worker $worker->{NUMBER}\n" if DEBUG;
+ store_fd({ _SHUTDOWN => 1 }, $worker->{SOCKET});
+ $worker->{WATCHER}->cancel; undef $worker->{WATCHER};
+ $worker->{SOCKET}->close; undef $worker->{SOCKET};
+ undef($workers[$worker->{NUMBER}]);
+
+ unless(grep defined($_), @workers) {
+ print "All workers shut down.\n" if DEBUG;
+ $callback->() if $callback;
+ }
+ }
+
+ sub shutdown_all_workers($) {
+ $callback = shift;
+
+ while(my $worker = pop @free_workers) {
+ shutdown_worker($worker);
+ }
+ }
+}
+
+sub kill_all_workers() {
+ kill 9, map($_->{PID}, @workers);
+}
+
+### Semi-private Functions ###
+
+sub do_callback_in_child {
+ my ($callback, $message) = @_;
+
+ if(my $worker = pop @free_workers) {
+ print "Asking worker ".$worker->{NUMBER}." to call ".$callback->{CALL}."\n" if DEBUG;
+ #store_fd([$unit], $worker->{SOCKET});
+ $worker->{UNIT} = [$callback, $message];
+
+ store_fd($worker->{UNIT}, $worker->{SOCKET});
+ } else {
+ push @queue, [$callback, $message];
+ print "Added to queue, length is now" . @queue if DEBUG;
+ }
+}
+
+### Internal Functions ###
+
+sub req_from_child($) {
+ my $event = shift;
+ my $nr = $event->w->data;
+ my $worker = $workers[$nr];
+ my $fd = $worker->{SOCKET};
+
+ my $req = eval { fd_retrieve($fd) };
+ die "Couldn't read the request: $@" if $@;
+
+ print "Got a ".$req->{CLASS}." message from worker ".$worker->{NUMBER}."\n" if DEBUG;
+
+ if($req->{CLASS} eq 'CALL') {
+ my @reply = safe_call($req->{FUNCTION}, $req->{ARGS});
+ store_fd(\@reply, $fd);
+ }
+ elsif($req->{CLASS} eq 'FINISHED') {
+ my $unit = $worker->{UNIT};
+ $worker->{UNIT} = undef;
+
+ print "Worker ".$worker->{NUMBER}." is now finished.\n" if DEBUG;
+
+ if($runlevel == ST_SHUTDOWN) {
+ shutdown_worker($worker);
+ return;
+ }
+
+ push @free_workers, $worker;
+
+ if(@queue) {
+ print "About to dequeue, length is now " . @queue if DEBUG;
+ do_callback_in_child(@{ shift @queue });
+ }
+
+ unit_finished($unit->[0], $unit->[1]);
+ }
+ elsif($runlevel != ST_SHUTDOWN) {
+ store_fd({ACK => 1}, $fd);
+ message($req);
+ }
+}
+
+sub do_exit() {
+ print "Worker ".@workers." shutting down.\n" if DEBUG;
+ $parent_sock->close;
+ exit;
+}
+
+sub loop($) {
+ my ($parent) = @_;
+
+ $ima_worker = 1;
+ $parent_sock = $parent;
+
+ SrSv::Process::Init::do_init();
+ module::begin();
+
+ store_fd({ CLASS => 'FINISHED' }, $parent);
+
+ while(my $unit = fd_retrieve($parent)) {
+ if(ref $unit eq 'HASH' and $unit->{_SHUTDOWN}) {
+ do_exit;
+ }
+ print "Worker ".@workers." is now busy.\n" if DEBUG;
+ call_callback(@$unit);
+
+ print "Worker ".@workers." is now free.\n" if DEBUG;
+ store_fd({ CLASS => 'FINISHED' }, $parent);
+ }
+
+ die "Lost contact with the mothership";
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::RunLevel;
+
+=head1 NAME
+
+SrSv::RunLevel - Control system state.
+
+=cut
+
+use strict;
+
+use Exporter 'import';
+
+BEGIN {
+ my %constants = (
+ ST_NORMAL => 1,
+ ST_SHUTDOWN => 2,
+ );
+
+ our @EXPORT_OK = (qw($runlevel main_shutdown emerg_shutdown), keys(%constants));
+ our %EXPORT_TAGS = (levels => [keys(%constants)]);
+
+ require constant; import constant (\%constants);
+}
+
+# FIXME: Uncommenting this breaks $ircd_ready for some reason.
+#use SrSv::IRCd::IO qw(ircd_disconnect);
+use SrSv::Process::Worker qw(ima_worker shutdown_all_workers kill_all_workers call_in_parent);
+use SrSv::Timer 'stop_timer';
+
+our $runlevel = ST_NORMAL;
+
+sub main_shutdown() {
+ call_in_parent(__PACKAGE__.'::_main_shutdown');
+}
+
+sub emerg_shutdown() {
+ $runlevel = ST_SHUTDOWN;
+ stop_timer;
+ shutdown_all_workers sub { exit; };
+
+ Event->timer(after => 5, cb => sub {
+ kill_all_workers;
+
+ exit;
+ });
+}
+
+sub _main_shutdown() {
+ ircd::agent_quit_all("Shutting down.");
+
+ emerg_shutdown;
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use SrSv::RunLevel;
+
+ main_shutdown;
+
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Shared;
+
+=head1 NAME
+
+SrSv::Shared - Share global variables among processes.
+
+=cut
+
+use strict;
+
+use SrSv::Debug;
+
+use SrSv::Process::Worker qw(ima_worker);
+use SrSv::Process::Init;
+
+use SrSv::Shared::Scalar;
+use SrSv::Shared::Array;
+use SrSv::Shared::Hash;
+
+our @shared_vars;
+
+sub import {
+ croak("Shared variables can only be created by the parent process")
+ if ima_worker;
+
+ my $class = shift;
+ my ($package) = caller;
+
+ for (@_) {
+ my $var = $_;
+ my $sigil = substr($var, 0, 1, '');
+ my $pkgvar = "$package\::$var";
+
+ push @shared_vars, [$sigil, $pkgvar];
+
+ # make the variable accessable in the parent.
+ no strict 'refs';
+ *$pkgvar = (
+ $sigil eq '$' ? \$$pkgvar :
+ $sigil eq '@' ? \@$pkgvar :
+ $sigil eq '%' ? \%$pkgvar :
+ croak("Only scalars, arrays, and hashes are supported")
+ );
+ }
+}
+
+proc_init {
+ return unless ima_worker;
+ no strict 'refs';
+
+ for (@shared_vars) {
+ my ($sigil, $var) = @$_;
+
+ if($sigil eq '$') {
+ tie ${$var}, 'SrSv::Shared::Scalar', $var;
+ }
+ elsif($sigil eq '@') {
+ tie @{$var}, 'SrSv::Shared::Array', $var;
+ }
+ elsif($sigil eq '%') {
+ tie %{$var}, 'SrSv::Shared::Hash', $var;
+ }
+
+ print "$sigil$var is now shared.\n" if DEBUG;
+ }
+};
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use SrSv::Shared qw($shared1 @shared2 %shared3);
+
+=head1 DESCRIPTION
+
+This module creates shared variables.
+
+=head1 CAVEATS
+
+Operations which iterate through an entire hash are not supported. This
+includes keys(), values(), each(), and assignment to list context. If you need
+to do these things, do them in the parent process. (See SrSv::Process::InParent)
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Shared::Array;
+
+=head1 NAME
+
+SrSv::Shared::Array - Used internally by SrSv::Shared.
+
+=cut
+
+use strict;
+no strict 'refs';
+
+use SrSv::Process::InParent qw(STORE FETCH FETCHSIZE STORESIZE CLEAR PUSH POP SHIFT UNSHIFT SPLICE);
+
+sub TIEARRAY {
+ my ($class, $name) = @_;
+
+ return bless \$name, $class;
+}
+
+sub STORE {
+ my ($self, $key, $value) = @_;
+
+ print "Store \@" . $$self . "\n" if SrSv::Shared::DEBUG;
+ return ${$$self}[$key] = $value;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+
+ print "Fetch \@" . $$self . "\n" if SrSv::Shared::DEBUG;
+ return ${$$self}[$key];
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+
+ return scalar @{$$self};
+}
+
+sub STORESIZE {
+ my ($self, $value) = @_;
+
+ return $#{$$self} = $value-1;
+}
+
+sub CLEAR {
+ my ($self) = @_;
+
+ return @{$$self} = ();
+}
+
+sub PUSH {
+ my $self = shift;
+ return push @{$$self}, @_;
+}
+
+sub POP {
+ my ($self) = @_;
+
+ return pop @{$$self};
+}
+
+sub SHIFT {
+ my ($self) = @_;
+
+ return shift @{$$self};
+}
+
+sub UNSHIFT {
+ my $self = shift;
+ return unshift(@{$$self}, @_);
+}
+
+sub SPLICE {
+ my $self = shift;
+ return splice(@{$$self}, @_);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Shared::Hash;
+
+=head1 NAME
+
+SrSv::Shared::Hash - Used internally by SrSv::Shared.
+
+=cut
+
+use strict;
+no strict 'refs';
+
+use Carp;
+
+use SrSv::Process::InParent qw(STORE FETCH DELETE CLEAR EXISTS SCALAR);
+
+sub TIEHASH {
+ my ($class, $name) = @_;
+
+ return bless \$name, $class;
+}
+
+sub STORE {
+ my ($self, $key, $value) = @_;
+
+# print "Store \%" . $$self . "\n" if SrSv::Shared::DEBUG;
+ return ${$$self}{$key} = $value;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+
+# print "Fetch \%" . $$self . "\n" if SrSv::Shared::DEBUG;
+ return ${$$self}{$key};
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+
+ print "DELETE \%" . $$self . "{$key}\n" if SrSv::Shared::DEBUG;
+ return delete(${$$self}{$key});
+}
+
+sub CLEAR {
+ my ($self) = @_;
+ print "CLEAR \%" . $$self . "\n" if SrSv::Shared::DEBUG;
+=cut
+ foreach my $key (keys %{$$self}) {
+ delete ($$self->{$key});
+ }
+ return %{$$self} = ();
+=cut
+ $$self = {};
+ return %{$$self};
+}
+
+sub EXISTS {
+ my ($self, $key) = @_;
+
+ return exists(${$$self}{$key});
+}
+
+# TODO: Fix these.
+sub FIRSTKEY {
+ croak "key listing not implemented yet";
+}
+
+sub NEXTKEY {
+ croak "key listing not implemented yet";
+}
+
+sub SCALAR {
+ my ($self) = @_;
+
+ return scalar(%{$$self});
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Shared::Scalar;
+
+=head1 NAME
+
+SrSv::Shared::Scalar - Used internally by SrSv::Shared.
+
+=cut
+
+use strict;
+no strict 'refs';
+
+use SrSv::Process::InParent qw(STORE FETCH);
+
+sub TIESCALAR {
+ my ($class, $name) = @_;
+
+ return bless \$name, $class;
+}
+
+sub STORE {
+ my ($self, $value) = @_;
+
+ print "Store \$" . $$self . "\n" if SrSv::Shared::DEBUG;
+ return ${$$self} = $value;
+}
+
+sub FETCH {
+ my ($self) = @_;
+
+ print "Fetch \$" . $$self . "\n" if SrSv::Shared::DEBUG;
+ return ${$$self};
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::SimpleHash;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(read_hash readHash write_hash writeHash) }
+
+sub writeHash {
+ my $hash = $_[0];
+ my $file = $_[1];
+
+ my $fh;
+ open $fh, '>', $file;
+
+ my @keys = keys(%$hash); my @values = values(%$hash);
+
+ for(my $i=0; $i<@keys; $i++) {
+ if(ref($values[$i]) eq 'ARRAY') {
+ chomp $keys[$i];
+ print $fh $keys[$i], " =[ ";
+ foreach my $atom (@{$values[$i]}) {
+ print $fh $atom, ", ";
+ }
+ print $fh "\n";
+ } else {
+ chomp $keys[$i]; chomp $values[$i];
+ print $fh $keys[$i], " = ", $values[$i], "\n";
+ }
+ }
+
+ close $fh;
+}
+
+sub readHash {
+ my $file = $_[0];
+ my %hash;
+
+ my $fh;
+ open $fh, $file
+ or die "ERROR: Unable to open config file $file: $!\n";
+
+ while(my $line = <$fh>) {
+ if($line =~ /^#|^\s*$/) { }
+ elsif($line =~ /^(\S+) ?= ?\[ ?(.*) ?]$/) {
+ my ($key, $value) = ($1, $2);
+ chomp $key; chomp $value;
+ $key =~ s/(^\s+|\s+$)//g;
+ $value =~ s/(^\s+|\s+$)//g;
+ $hash{$key} = [ split(/, /, $value) ];
+ }
+ elsif($line =~ /^\S+ ?= ?/) {
+ my ($key, $value) = split(/ ?= ?/, $line, 2);
+ chomp $key; chomp $value;
+ if($value eq 'undef') {
+ $value = undef;
+ }
+ $key =~ s/(^\s+|\s+$)//g;
+ $value =~ s/(^\s+|\s+$)//g;
+ $hash{$key} = $value;
+ }
+ else {
+ die "Malformed config file: $file\n";
+ }
+ }
+ close $fh;
+
+ return (%hash);
+}
+
+BEGIN { # The same functions, now with less camelCase
+ *write_hash = \&writeHash;
+ *read_hash = \&readHash;
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+=pod
+ Parses the TOR router list for exit-nodes, and optionally
+ for exit-nodes that can connect to our services.
+
+ Interface still in progress.
+=cut
+
+package SrSv::TOR;
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw( getTorRouters ); }
+
+sub openURI($) {
+ my ($URI) = @_;
+ my $data;
+ if($URI =~ s/^file:\/\///i) {
+ use IO::File;
+ my $fh = IO::File->new($URI, 'r') or die;
+ return $fh;
+ } else {
+ # assume HTTP/FTP URI
+=cut use IO::Pipe;
+ my $fh = IO::Pipe->new();
+ $fh->reader(qq(wget -q -O - $URI)) or die;
+=cut
+ use WWW::Mechanize;
+ my $mech = WWW::Mechanize->new();
+ $mech->get($URI) or die $!;
+ my $content = $mech->content;
+ return $content;
+ }
+}
+
+our %TOR_cmdhash;
+BEGIN {
+%TOR_cmdhash = (
+ 'r' => \&TOR_r,
+ 's' => \&TOR_s,
+ 'router' => \&TOR_router,
+ 'reject' => \&TOR_reject,
+ 'accept' => \&TOR_accept,
+);
+}
+
+sub parseTorRouterList($) {
+ my ($fh) = @_;
+ our (%currentRouter, @routerList);
+ foreach my $l (ref($fh) ? <$fh> : split($/, $fh)) {
+ my ($tok, undef) = split(' ', $l, 2);
+ #print "$l";
+ chomp $l;
+ if(my $code = $TOR_cmdhash{$tok}) {
+ &$code($l);
+ }
+ }
+ sub TOR_r {
+ my ($l) = @_;
+ #r atari i2i65Qm8DXfRpHVk6N0tcT0fxvs djULF2FbASFyIzuSpH1Zit9cYFc 2007-10-07 00:19:17 85.31.187.200 9001 9030
+ my (undef, $name, undef, undef, undef, $ip, $in_port, $dir_port) = split(' ', $l);
+ %currentRouter = ( NAME => $name, IP => $ip, IN_PORT => $in_port, DIR_PORT => $dir_port );
+ return;
+ }
+ sub TOR_s {
+ my ($l) = @_;
+ if($l =~ /^s (.*)/) {
+ #s Exit Fast Guard Stable Running V2Dir Valid
+ my $tokens = $1;
+ # uncomment the conditional if you trust the router status flags
+ #if($tokens =~ /Exit/) {
+ push @routerList, $currentRouter{IP};
+ #}
+ }
+ }
+ sub TOR_router {
+ my ($l) = @_;
+ my (undef, $name, $ip, $in_port, undef, $dir_port) = split(' ', $l);
+ push @routerList, processTorRouter(%currentRouter) if scalar(%currentRouter);
+ %currentRouter = ( NAME => $name, IP => $ip, IN_PORT => $in_port, DIR_PORT => $dir_port );
+ return;
+ }
+ sub TOR_reject {
+ my ($l) = @_;
+ my ($tok, $tuple) = split(' ', $l);
+ my ($ip, $ports) = split(':', $tuple);
+ push @{$currentRouter{REJECT}}, "$ip:$ports";
+ }
+ sub TOR_accept {
+ my ($l) = @_;
+ my ($tok, $tuple) = split(' ', $l);
+ my ($ip, $ports) = split(':', $tuple);
+ push @{$currentRouter{ACCEPT}}, "$ip:$ports";
+ }
+ #close $fh;
+ return @routerList;
+}
+
+sub processTorRouter(%) {
+# only used for v1, and possibly v3
+ my (%routerData) = @_;
+ my @rejectList = ( $routerData{REJECT} and scalar(@{$routerData{REJECT}}) ? @{$routerData{REJECT}} : () );
+ my @acceptList = ( $routerData{ACCEPT} and scalar(@{$routerData{ACCEPT}}) ? @{$routerData{ACCEPT}} : () );
+ return () if $routerData{IP} =~ /^(127|10|192\.168)\./;
+ if ( (scalar(@rejectList) == 1) and ($rejectList[0] eq '*:*') ) {
+ #print STDERR "$routerData{IP} is not an exit node.\n";
+ return ();
+ } else {
+ #print STDERR "$routerData{IP} is an exit node.\n";
+ return ($routerData{IP});
+ }
+}
+
+sub getTorRouters($) {
+ my ($URI) = @_;
+ return parseTorRouterList(openURI($URI));
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Text::Codes;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(strip_codes) }
+
+sub strip_codes(@) {
+ my (@in) = @_;
+ foreach my $string (@in) {
+ $string =~ s/\003[0-9]{1,2}(?:,[0-9]{1,2})?|[[:cntrl:]]//g;
+ }
+ return (wantarray ? @in : $in[0]);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Text::Format;
+
+use strict;
+
+use Encode 'encode';
+
+use constant {
+ MAX_WIDTH => 96,
+ COLORS => 1,
+ BULLET => encode('utf8', "\x{2022} "),
+};
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw( columnar enum wordwrap ) }
+
+use SrSv::Text::Codes 'strip_codes';
+
+BEGIN { if(COLORS) {
+ *line_post = sub ($$) {
+ my ($bg, $t) = @_;
+
+ $t =~ s/^(.{60}.*?)\s*$/$1 / if length $t > 60;
+ $t = "\0031,15" . $t if $bg;
+
+ return split($/, $t);
+ }
+} else {
+ *line_post = sub ($$) {
+ my ($bg, $t) = @_;
+
+ $t =~ s/ +$//;
+ $t = ' ' unless $t;
+
+ return split($/, $t);
+ }
+} }
+
+sub columnar(@) {
+ my $opts;
+ $opts = shift if ref($_[0]) eq 'HASH';
+ my (@mlen, @out);
+
+ $opts->{DOUBLE} = 0 if $opts->{NOHIGHLIGHT};
+ my $double = $opts->{DOUBLE};
+ my $border = $opts->{BORDER};
+ my $justified = $opts->{JUSTIFIED};
+
+ foreach my $x (@_) {
+ next unless ref($x) eq 'ARRAY';
+
+ for(my $i; $i<@$x; $i++) {
+ my $nc = strip_codes($x->[$i]);
+ my $len = length($nc);
+ $mlen[$i] = $len if $len > $mlen[$i];
+ }
+ }
+
+ pop @mlen if $double;
+
+ my $width = 2; # 2 leading spaces
+ my $borderLine = '+';
+ foreach my $x (@mlen) {
+ my $cellWidth = ($x ? $x + 2 : 0);
+ $width += $cellWidth;
+ $borderLine .= '-'x($cellWidth+1).'+';
+ }
+ $border = $border && ($width < MAX_WIDTH);
+
+ if($double and @mlen) {
+ $mlen[-1] += MAX_WIDTH - $width;
+ $width = MAX_WIDTH;
+ }
+ else {
+ $width = MAX_WIDTH if $width > MAX_WIDTH;
+ }
+
+ my ($bg, $collapsed);
+ my $headerBorder = 0;
+ foreach my $x (@_) {
+ if(ref $x eq 'HASH') {
+ if(my $t = $x->{COLLAPSE}) {
+ next unless @$t;
+ if($border) {
+ push @out, $borderLine;
+ }
+ push @out, ' ' unless $collapsed;
+ @$t = map BULLET . $_, @$t if($x->{BULLET});
+ push @out, @$t;
+ $collapsed = 1;
+ }
+ else { $collapsed = 0 }
+
+ if(my $t = $x->{FULLROW}) {
+ my $nc = strip_codes($t);
+ push @out, line_post $bg, ' ' . $t . ' ' x ($width - length($nc));
+ }
+
+ next;
+ }
+
+ my $str = ($border ? '| ' : ' ');
+ #my $border = '+'.'-'x($width+1).'+';
+ for(my $i; $i<@mlen; $i++) {
+ my $nc = strip_codes($x->[$i]);
+ if($justified && $i == 0) {
+ $str .= ' ' x (($mlen[$i] - length($nc) + ($mlen[$i] ? 2 : 0))).
+ $x->[$i] . ($border ? '| ' : ' ');
+ } else {
+ $str .= $x->[$i] .' ' x (($mlen[$i] - length($nc) + ($mlen[$i] ? 2 : 0))).
+ ($border ? '| ' : ' ');
+ }
+ }
+
+ if($border) {
+ if($headerBorder >= 2) {
+ } else {
+ push @out, $borderLine;
+ $headerBorder++
+ }
+ }
+ push @out, line_post $bg, $str;
+
+ if($double and $x->[-1]) {
+ my $t = $x->[-1];
+ push @out, line_post $bg, " $t" . ' ' x ($width - 4 - length strip_codes $t);
+ }
+ }
+ continue {
+ $bg = !$bg unless $opts->{NOHIGHLIGHT};
+ }
+ push @out, $borderLine if $border && !$collapsed && scalar(@_)!=1;
+
+ push @out, ' (empty list)' unless @out;
+ push @out, ' --';
+
+ if(my $t = $opts->{TITLE}) {
+ unshift @out, "\037$t" . (' ' x ($width - length strip_codes $t));
+ }
+
+ return @out;
+}
+
+# Formats a list like "foo, bar, and baz"
+sub enum($@) {
+ my ($conj, @list) = @_;
+
+ my $el;
+ $el = " $conj ".pop(@list) if(@list > 1);
+ if(@list > 1) {
+ $el = join(", ", @list) . ",$el";
+ } else {
+ $el = $list[0].$el;
+ }
+
+ return $el;
+}
+
+# Portions of wordwrap() taken from
+# Bjoern 'fuchs' Krombholz splitlong.pl
+# bjkro@gmx.de
+sub wordwrap ($$) {
+ my ($data, $maxlength) = @_;
+
+ return ($data)
+ if (length($data) <= $maxlength);
+
+ my $lstart = '...';
+ my $lend = '...';
+ my $maxlength2 = $maxlength - length($lend);
+
+ my @spltarr;
+ while (length($data) > ($maxlength2)) {
+ my $pos = rindex($data, " ", $maxlength2);
+ push @spltarr, substr($data, 0, ($pos < ($maxlength/10 + 4)) ? $maxlength2 : $pos) . $lend;
+ $data = $lstart . substr($data, ($pos < ($maxlength/10 + 4)) ? $maxlength2 : $pos + 1);
+ }
+ push @spltarr, $data;
+
+ return @spltarr;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Time;
+
+use strict;
+use integer;
+use Time::Local;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw( @months @days
+ gmtime2 tz_time gmt_date local_date
+ time_ago time_rel time_rel_long_all
+ parse_time split_time
+ get_nextday get_nextday_time get_monthdays
+ get_nexthour get_nexthour_time
+ )
+}
+
+our @months = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
+our @days = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );
+
+sub _time_text($) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime(shift);
+ return $mday.'/'.$months[$mon].'/'. substr($year, -2, 2).' '.
+ sprintf("%02d:%02d", $hour, $min);
+}
+
+sub gmtime2(;$) {
+ my ($time) = @_;
+ $time = time() unless $time;
+ return _time_text($time) . ' GMT';
+}
+
+sub tz_time($;$) {
+ my ($tzoffset, $time) = @_;
+ return _time_text(($time ? $time : time()) + tz_to_offset($tzoffset));
+}
+
+sub tz_to_offset($) {
+ my ($offset) = @_;
+ # offset is a signed integer corresponding to 1/4 hr increments
+ # or 900 seconds (15 minutes)
+ return ($offset * 900);
+}
+
+sub _date_text($) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime(shift);
+ return (!wantarray ? ($year+1900).' '.$months[$mon].' '.$mday : ($year + 1900, $mon+1, $months[$mon], $mday));
+}
+
+sub gmt_date(;$) {
+ my ($time) = @_;
+ $time = time() unless $time;
+ return _date_text($time);
+}
+
+sub local_date($;$) {
+ my ($tzoffset, $time) = @_;
+ return _date_text(($time ? $time : time()) + tz_to_offset($tzoffset));
+}
+
+sub parse_time($) {
+ my ($str) = @_;
+ my $out;
+ $str =~ s/^\+//;
+ $str = lc($str);
+
+ my @vals = split(/(?<!\d)(?=\d+\w)/, $str);
+
+ foreach my $val (@vals) {
+ $val =~ /(\d+)(\w)/;
+ my ($num, $pos) = ($1, $2);
+
+ if($pos eq 'w') { $num *= (86400*7) }
+ elsif($pos eq 'd') { $num *= 86400 }
+ elsif($pos eq 'h') { $num *= 3600 }
+ elsif($pos eq 'm') { $num *= 60 }
+ elsif($pos ne 's') { return undef }
+
+ $out += $num;
+ }
+
+ return $out;
+}
+
+sub split_time($) {
+ no integer; # We might want to pass in a float value for $difference
+ my ($difference) = @_;
+ my ($weeks, $days, $hours, $minutes, $seconds);
+ $seconds = $difference % 60 + ($difference - int($difference));
+ $difference = ($difference - $seconds) / 60;
+ $minutes = $difference % 60;
+ $difference = ($difference - $minutes) / 60;
+ $hours = $difference % 24;
+ $difference = ($difference - $hours) / 24;
+ $days = $difference % 7;
+ $weeks = ($difference - $days) / 7;
+
+ return ($weeks, $days, $hours, $minutes, $seconds);
+}
+
+sub time_ago($;$) {
+ return time_rel(time() - $_[0], $_[1]);
+}
+
+sub time_rel($;$) {
+ my ($time, $all) = @_;
+
+ if ($time >= 2419200) { # 86400 * 7 * 4
+ my ($years, $months, $weeks, $days) = __time_rel_long(time() - $time);
+ if($years or $months or $weeks or $days) {
+ my $text = '';
+ if($years) {
+ $text = "$years year".($years !=1 ? 's' : '');
+ }
+ if($months) {
+ $text .= (length($text) ? ' ' : '')."$months month".($months !=1 ? 's' : '');
+ if ($years && !$all) {
+ return $text;
+ }
+ }
+ if($weeks) {
+ $text .= (length($text) ? ' ' : '')."$weeks week".($weeks !=1 ? 's' : '');
+ if ($months && !$all) {
+ return $text;
+ }
+ }
+ if($days) {
+ $text .= (length($text) ? ' ' : '')."$days day".($days !=1 ? 's' : '');
+=cut
+ if ($weeks && !$all) {
+ return $text;
+ }
+=cut
+ }
+ return $text;
+=cut
+ return ( $years ? "$years year".($years !=1 ? 's' : '') : '' ).
+ ( $months ? ($years ? ', ' : '')."$months month".( $months!=1 ? 's' : '' ) : '').
+ ( $weeks ? (($years or $months) ? ', ' : '')."$weeks week".( $weeks!=1 ? 's' : '' ) : '').
+ ( $days ? (($months or $years or $weeks) ? ', ' : '')."$days day".($days!=1 ? 's' : '') : '' )
+ ;
+=cut
+ }
+ }
+
+ my ($weeks, $days, $hours, $minutes, $seconds) = split_time($time);
+
+ my $text;
+# if($time >= 604800) { # 86400 * 7 }
+ if($weeks) {
+ $text = "$weeks week".($weeks!=1 ? 's' : '');
+=cut
+ return "$weeks week".
+ ($weeks!=1 ? 's' : '').
+ ", $days day".
+ ($days!=1 ? 's' : '');
+=cut
+ }
+ if($days) {
+ $text .= (length($text) ? ' ' : '')."$days day".($days!=1 ? 's' : '');
+ return $text if $weeks && !$all;
+=cut
+ return "$days day".
+ ($days!=1 ? 's' : '').
+ ", $hours hour".
+ ($hours!=1 ? 's' : '');
+=cut
+ }
+ if($hours) {
+ $text .= (length($text) ? ' ' : '')."$hours hour".($hours!=1 ? 's' : '');
+ return $text if $days && !$all;
+=cut
+ return "$hours hour".
+ ($hours!=1 ? 's' : '').
+ ", $minutes minute".
+ ($minutes!=1 ? 's' : '');
+=cut
+ }
+ if($minutes) {
+ $text .= (length($text) ? ' ' : '')."$minutes minute".($minutes!=1 ? 's' : '');
+ return $text if $hours && !$all;
+=cut return "$minutes minute".
+ ($minutes!=1 ? 's' : '').
+ ", $seconds second".
+ ($seconds!=1 ? 's' : '');
+=cut
+ }
+ if($seconds) {
+ $text .= (length($text) ? ' ' : '')."$seconds second".($seconds!=1 ? 's' : '');
+=cut
+ return "$seconds second".
+ ($seconds!=1 ? 's' : '');
+=cut
+ }
+ if(!($weeks || $days || $hours || $minutes || $seconds) ) {
+ return '0 seconds';
+ }
+ return $text;
+}
+
+# This is for cases over 4 weeks, when we need years, months, weeks, and days
+sub __time_rel_long($;$) {
+ my ($lesser_time, $greater_time) = @_;
+ $greater_time = time() unless $greater_time;
+
+ my ($sec1, $min1, $hour1, $mday1, $month1, $year1, undef, undef, undef) = gmtime($lesser_time);
+ my ($sec2, $min2, $hour2, $mday2, $month2, $year2, undef, undef, undef) = gmtime($greater_time);
+
+ my ($result_years, $result_months, $result_weeks, $result_days,
+ $result_hours, $result_mins, $result_secs);
+ $result_secs = $sec2 - $sec1;
+ $result_mins = $min2 - $min1;
+ if($result_secs < 0) {
+ $result_secs += 60; $result_mins--;
+ }
+ $result_hours = $hour2 - $hour1;
+ if($result_mins < 0) {
+ $result_mins += 60; $result_hours--;
+ }
+ $result_days = $mday2 - $mday1;
+ if($result_hours < 0) {
+ $result_hours += 24; $result_days--;
+ }
+ $result_months = $month2 - $month1;
+ if($result_days < 0) {
+ $result_days += get_monthdays(
+ ($month2 == 0 ? 11 : $month2 - 1),
+ ($month2 == 0 ? $year2 - 1: $year2));
+ $result_months--;
+ }
+ # The following division relies on integer division, as 'use integer' is decl'd above.
+ $result_weeks = $result_days / 7;
+ $result_days = $result_days % 7;
+ $result_years = $year2 - $year1;
+ if($result_months < 0) {
+ $result_months += 12; $result_years--
+ }
+ return ($result_years, $result_months, $result_weeks, $result_days, $result_hours, $result_mins, $result_secs);
+}
+
+# Apologize about the unreadability, but the alternative is about 4 times as long
+# This is for use when we want as precise a time-difference as possible.
+sub time_rel_long_all($;$) {
+ my ($lesser_time, $greater_time) = @_;
+ $greater_time = time() unless $greater_time;
+ my ($years, $months, $weeks, $days, $hours, $minutes, $seconds) = __time_rel_long($lesser_time);
+ return ( $years ? "$years year".($years !=1 ? 's' : '') : '' ).
+ ( $months ? ($years ? ', ' : '')."$months month".( $months!=1 ? 's' : '' ) : '').
+ ( $weeks ? (($years or $months) ? ', ' : '')."$weeks week".( $weeks!=1 ? 's' : '' ) : '').
+ ( $days ? (($months or $years or $weeks) ? ', ' : '')."$days day".($days!=1 ? 's' : '') : '' ).
+ ( $hours ? (($days or $months or $years or $weeks) ? ', ' : '')."$hours hour".($hours!=1 ? 's' : '') : '' ).
+ ( $minutes ? (($hours or $days or $months or $years or $weeks) ? ', ' : '')."$minutes minute".($minutes!=1 ? 's' : '') : '' ).
+ ( $seconds ? (($minutes or $days or $months or $years or $weeks) ? ', ' : '')."$seconds second".($seconds!=1 ? 's' : '') : '' )
+ ;
+
+}
+
+sub get_nextday($$$) {
+ my ($mday, $mon, $year) = @_;
+ $year += 1900 if $year < 1582; #Gregorian calendar was somewhere around here...
+
+ my $monthdays = get_monthdays($mon, $year);
+ $mday++;
+ if($mday > $monthdays) {
+ $mday %= $monthdays;
+ $mon++;
+ }
+ if($mon >= 12) {
+ $mon %= 12;
+ $year++;
+ }
+ return ($mday, $mon, $year);
+}
+sub get_nextday_time(;$) {
+ my ($time) = @_;
+ $time = time() unless $time;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
+ return Time::Local::timegm(0,0,0,get_nextday($mday, $mon, $year));
+}
+
+sub get_nexthour($$$$) {
+ my ($hour, $mday, $mon, $year) = @_;
+# $minute++;
+# if($minute >= 60) {
+# $minute %= 60;
+# $hour++;
+# }
+ $hour++;
+ if($hour >= 24) {
+ $hour %= 24;
+ ($mday, $mon, $year) = get_nextday($mday, $mon, $year)
+ }
+ return ($hour, $mday, $mon, $year);
+}
+sub get_nexthour_time(;$) {
+ my ($time) = @_;
+ $time = time() unless $time;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
+ return Time::Local::timegm(0,0,get_nexthour($hour, $mday, $mon, $year));
+}
+
+# This function is only correct/valid for Gregorian dates.
+# Not IVLIAN dates.
+sub get_monthdays {
+# $month is 0-11 not 1-12
+ my ($month, $year) = @_;
+ sub m30($) { return 30; }
+ sub m31($) { return 31; }
+ sub mFeb($) {
+ my ($year) = @_;
+ if(($year % 100 and !($year % 4)) or !($year % 400)) {
+ return 29;
+ } else {
+ return 28;
+ }
+ }
+ # this is the common table, but note +1 below
+ # as gmtime() and friends return months from 0-11 not 1-12
+ my %months = (
+ 1 => \&m31,
+ 3 => \&m31,
+ 5 => \&m31,
+ 7 => \&m31,
+ 8 => \&m31,
+ 10 => \&m31,
+ 12 => \&m31,
+
+ 4 => \&m30,
+ 6 => \&m30,
+ 9 => \&m30,
+ 11 => \&m30,
+
+ 2 => \&mFeb,
+ );
+
+ $year += 1900 if $year < 1582; #Gregorian calendar was somewhere around here...
+ return $months{$month+1}($year);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Timer;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(add_timer begin_timer stop_timer) }
+
+use Event;
+
+use SrSv::Debug;
+use SrSv::Process::InParent qw(_add_timer stop_timer);
+use SrSv::Message qw(message add_callback);
+
+our @timers;
+our $timer_watcher;
+
+add_callback({
+ TRIGGER_COND => { CLASS => 'TIMER' },
+ CALL => 'SrSv::Timer::call',
+});
+
+if(DEBUG()) {
+ add_timer('hello', 2, __PACKAGE__, 'SrSv::Timer::test');
+ sub test { ircd::privmsg('ServServ', '#surrealchat', $_[0]) };
+}
+
+sub add_timer($$$$) {
+ my ($token, $delay, $owner, $callback) = @_;
+
+ if($callback !~ /::/) {
+ $callback = caller() . "::$callback";
+ }
+
+ _add_timer($token, $delay, $owner, $callback);
+}
+
+sub _add_timer {
+ my ($token, $delay, $owner, $callback) = @_;
+
+ push @{ $timers[$delay] }, [$token, $owner, $callback];
+}
+
+sub begin_timer {
+ $timer_watcher = Event->timer(interval => 1, cb => \&trigger);
+}
+
+sub stop_timer {
+ $timer_watcher->cancel if $timer_watcher;
+}
+
+sub trigger {
+ my $timers = shift @timers;
+
+ foreach my $timer (@$timers) {
+ message({
+ CLASS => 'TIMER',
+ TOKEN => $timer->[0],
+ OWNER => $timer->[1],
+ REALCALL => $timer->[2],
+ CALL => 'SrSv::Timer::call'
+ });
+ }
+}
+
+sub call {
+ no strict 'refs';
+ my ($message, $callback) = @_;
+
+ &{$message->{REALCALL}}($message->{TOKEN});
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Unreal::Base64;
+
+=head1 NAME
+
+SrSv::Unreal::Base64 - Implementation of the UnrealIRCd Base64 encoding
+
+=cut
+
+use strict;
+use SrSv::64bit;
+BEGIN {
+ if(!HAS_64BIT_INT) {
+ eval {
+ require Math::BigInt;
+ import Math::BigInt try => 'GMP';
+ };
+ if($@) {
+ print STDERR "Running old version of perl/Math::BigInt.\n", $@, "Trying again.\n";
+ require Math::BigInt;
+ import Math::BigInt;
+ }
+ }
+}
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(b64toi itob64); }
+
+# ':' and '#' and '&' and '+' and '@' must never be in this table. */
+# these tables must NEVER CHANGE! >) */
+our @int6_to_base64_map = (
+ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D',
+ 'E', 'F',
+ 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
+ 'U', 'V',
+ 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
+ 'k', 'l',
+ 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z',
+ '{', '}'
+);
+
+our @base64_to_int6_map = (
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, -1, -1, -1, -1, -1, -1,
+ -1, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24,
+ 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, -1, -1, -1, -1, -1,
+ -1, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
+ 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, -1, 63, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1
+);
+
+*b64toi = \&base64_to_int;
+sub base64_to_int($) {
+ my ($base64) = @_;
+ my $val = 0;
+ #wKgIAw==
+ if(length($base64) > 8) {
+ warn "greater-than-32bit base64($base64) in base64_to_int";
+ $val = (HAS_64BIT_INT ? 0 : Math::BigInt->bzero());
+ } else {
+ $val = 0;
+ }
+
+ foreach my $ch (split(//, $base64)) {
+ $val <<= 6;
+ $val += $base64_to_int6_map[ord($ch)];
+ }
+ return $val;
+}
+
+*itob64 = \&int_to_base64;
+sub int_to_base64($) {
+ my ($val) = @_;
+
+ my $base64 = '';
+ do {
+ $base64 .= $int6_to_base64_map[$val & 63];
+ } while ($val >>= 6);
+ return scalar reverse($base64);
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use SrSv::Unreal::Base64;
+ $integer = b64toi($base64);
+ $base64 = itob64($integer);
+
+=head1 NOTES
+
+As far as I know, all usage of these functions will accept or return
+a 32-bit integer. The only exception is for IPv6, but NICKIP uses the
+standard table anyway.
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Unreal::Modes;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(@opmodes %opmodes $scm $ocm $acm sanitize_mlockable) }
+
+our @opmodes = ('v', 'h', 'o', 'a', 'q');
+our %opmodes = (
+ v => 1,
+ h => 2,
+ o => 4,
+ a => 8,
+ q => 16
+);
+
+# Channel modes with arguments:
+our $scm = qr/^[bevhoaqI]$/;
+
+# Channel modes with only one setting:
+our $ocm = qr/^[kfLlj]$/;
+
+# Allowed channel modes:
+our $acm = qr/^[cfijklmnprstzACGIMKLNOQRSTVu]$/;
+
+sub sanitize_mlockable($) {
+ my ($inModes, @inParms) = split(/ /, $_[0]);
+ my ($outModes, @outParms);
+
+ my $sign = '+';
+ foreach my $mode (split(//, $inModes)) {
+ if ($mode =~ /[+-]/) {
+ $sign = $mode;
+ $outModes .= $mode;
+ next;
+ }
+ my $parm = shift @inParms
+ if (($mode =~ $ocm or $mode =~ $scm) and $sign eq '+');
+
+ if ($mode =~ $scm) {
+ next;
+ } else {
+ $outModes .= $mode;
+ push @outParms, $parm if $parm;
+ }
+ }
+
+ return $outModes . ' ' . join(' ', @outParms);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::IRCd::Parse;
+
+use strict;
+
+use Exporter 'import';
+# parse_sjoin shouldn't get used anywhere else, as we never produce SJOINs
+# parse_tkl however is used for loopbacks.
+BEGIN { our @EXPORT_OK = qw(parse_line parse_tkl) }
+
+# FIXME
+BEGIN { *SJB64 = \&ircd::SJB64; *CLK = \&ircd::CLK; *NICKIP = \&ircd::NICKIP; }
+
+use SrSv::Conf 'main';
+use SrSv::Conf2Consts 'main';
+
+use Socket;
+BEGIN {
+ if(main_conf_ipv6) {
+ require Socket6; import Socket6;
+ }
+}
+
+use SrSv::Debug;
+use SrSv::IRCd::State qw($ircline $remoteserv create_server get_server_children set_server_state get_server_state %IRCd_capabilities);
+use SrSv::IRCd::Queue qw(queue_size);
+use SrSv::IRCd::IO qw( ircsend );
+use SrSv::Unreal::Modes qw(%opmodes);
+
+# Unreal uses its own modified base64 for everything except NICKIP
+use SrSv::Unreal::Base64 qw(b64toi itob64);
+
+# Unreal uses unmodified base64 for NICKIP.
+# Consider private implementation,
+# tho MIME's is probably faster
+use MIME::Base64;
+
+# FIXME
+use constant {
+ # Wait For
+ WF_NONE => 0,
+ WF_NICK => 1,
+ WF_CHAN => 2,
+ WF_ALL => 3,
+};
+
+use SrSv::Shared qw(@servernum);
+
+our %cmdhash;
+
+sub parse_line($) {
+ my ($in) = @_;
+ return unless $in;
+ my $cmd;
+
+ if($in =~ /^(?:@|:)(\S+) (\S+)/) {
+ $cmd = $2;
+ }
+ elsif ($in =~ /^(\S+)/) {
+ $cmd = $1;
+ }
+
+ my $sub = $cmdhash{$cmd};
+ unless (defined($sub)) {
+ print "Bailing out from $ircline:$cmd for lack of cmdhash\n" if DEBUG();
+ return undef();
+ }
+ my ($event, $src, $dst, $wf, @args) = &$sub($in);
+ unless (defined($event)) {
+ print "Bailing out from $ircline:$cmd for lack of event\n" if DEBUG;
+ return undef();
+ }
+ #return unless defined $event;
+
+ my (@recipients, @out);
+ if(defined($dst)) {
+ #$args[$dst] = lc $args[$dst];
+ @recipients = split(/\,/, $args[$dst]);
+ }
+ #if(defined($src)) { $args[$src] = lc $args[$src]; }
+
+ if(@recipients > 1) {
+ foreach my $rcpt (@recipients) {
+ $args[$dst] = $rcpt;
+ push @out, [$event, $src, $dst, $wf, [@args]];
+ }
+ } else {
+ @out = [$event, $src, $dst, $wf, [@args]];
+ }
+
+ return @out;
+}
+
+sub parse_sjoin($$$$) {
+ my ($server, $ts, $cn, $parms) = @_;
+ my (@users, @bans, @excepts, @invex, @blobs, $blobs, $chmodes, $chmodeparms);
+
+ $server = '' unless $server;
+
+ if($parms =~ /^:(.*)/) {
+ $blobs = $1;
+ } else {
+ ($chmodes, $blobs) = split(/ :/, $parms, 2);
+ ($chmodes, $chmodeparms) = split(/ /, $chmodes, 2);
+ }
+ @blobs = split(/ /, $blobs);
+
+ foreach my $x (@blobs) {
+ if($x =~ /^(\&|\"|\')(.*)$/) {
+ my $type;
+ push @bans, $2 if $1 eq '&';
+ push @excepts, $2 if $1 eq '"';
+ push @invex, $2 if $1 eq "\'";
+ } else {
+ $x =~ /^([*~@%+]*)(.*)$/;
+ my ($prefixes, $nick) = ($1, $2);
+ my @prefixes = split(//, $prefixes);
+ my $op = 0;
+ foreach my $prefix (@prefixes) {
+ $op |= $opmodes{q} if ($prefix eq '*');
+ $op |= $opmodes{a} if ($prefix eq '~');
+ $op |= $opmodes{o} if ($prefix eq '@');
+ $op |= $opmodes{h} if ($prefix eq '%');
+ $op |= $opmodes{v} if ($prefix eq '+');
+ }
+
+ push @users, { NICK => $nick, __OP => $op };
+ }
+ }
+
+ return ($server, $cn, $ts, $chmodes, $chmodeparms, \@users, \@bans, \@excepts, \@invex);
+}
+
+sub parse_tkl ($) {
+ my ($in) = @_;
+ # This function is intended to accept ALL tkl types,
+ # tho maybe not parse all of them in the first version.
+
+ # Discard first token, 'TKL'
+ my (undef, $sign, $type, $params) = split(/ /, $in, 4);
+
+ # Yes, TKL types are case sensitive!
+ # also be aware (and this applies to the net.pm generator functions too)
+ # This implementation may appear naiive, but Unreal assumes that, for a given
+ # TKL type, that all parameters are non-null.
+ # Thus, if any parameters ARE null, Unreal WILL segfault.
+ ## Update: this problem may have been fixed since Unreal 3.2.2 or so.
+ if ($type eq 'G' or $type eq 'Z' or $type eq 's' or $type eq 'Q') {
+ # format is
+ # TKL + type ident host setter expiretime settime :reason
+ # TKL - type ident host setter
+ # for Q, ident is always '*' or 'h' (Services HOLDs)
+ if ($sign eq '+') {
+ my ($ident, $host, $setter, $expire, $time, $reason) = split(/ /, $params, 6);
+
+ $reason =~ s/^\://;
+ return ($type, +1, $ident, $host, $setter, $expire, $time, $reason);
+ }
+ elsif($sign eq '-') {
+ my ($ident, $host, $setter) = split(/ /, $params, 3);
+ return ($type, -1, $ident, $host, $setter);
+ }
+ }
+ elsif($type eq 'F') {
+ # TKL + F cpnNPq b saturn!attitude@netadmin.SCnet.ops 0 1099959668 86400 Possible_mIRC_DNS_exploit :\/dns (\d+\.){3}\d
+ # TKL + F u g saturn!attitude@saturn.netadmin.SCnet.ops 0 1102273855 604800 sploogatheunbreakable:_Excessively_offensive_behavior,_ban_evasion. :.*!imleetnig@.*\.dsl\.mindspring\.com
+ # TKL - F u Z tabris!northman@tabris.netadmin.SCnet.ops 0 0 :do_not!use@mask
+ if ($sign eq '+') {
+ my ($target, $action, $setter, $expire, $time, $bantime, $reason, $mask) = split(/ /, $params, 8);
+ $mask =~ s/^\://;
+ return ($type, +1, $target, $action, $setter, $expire, $time, $bantime, $reason, $mask);
+ }
+ elsif($sign eq '-') {
+ my ($target, $action, $setter, $expire, $time, $mask) = split(/ /, $params, 6);
+ $mask =~ s/^\://;
+ return ($type, -1, $target, $action, $setter, $mask);
+ }
+ }
+}
+
+sub PING($) {
+ my ($event, $src, $dst, @args);
+ $_[0] =~ /^(?:8|PING) :(\S+)$/;
+ # ($event, $src, $dst, $args)
+ return ('PING', undef, undef, WF_NONE, $1);
+}
+
+sub EOS($) {
+ my $event;
+ $_[0] =~ /^(@|:)(\S+) (?:EOS|ES)/; # Sometimes there's extra crap on the end?
+ my $server;
+ if ($1 eq '@') {
+ $server = $servernum[b64toi($2)];
+ }
+ else {
+ $server = $2;
+ }
+ set_server_state($server, 1);
+ return undef() unless get_server_state($remoteserv);
+ if($server eq $remoteserv) { $event = 'SEOS' } else { $event = 'EOS' }
+ print "Ok. we had EOS\n";
+ return ($event, undef, undef, WF_ALL, $server);
+}
+
+sub SERVER($) {
+ #ircd::debug($_[0]) if $debug;
+ if($_[0] =~ /^(?:SERVER|\') (\S+) (\S+) :(U[0-9]+)-([A-Za-z0-9]+)-([0-9]+) (.*)$/) {
+ # SERVER test-tab.surrealchat.net 1 :U2307-FhinXeOoZEmM-200 SurrealChat
+ # cmd, servername, hopCount, U<protocol>-<buildflags>-<numeric> infoLine
+ $remoteserv = $1;
+ create_server($1);
+ $servernum[$5] = $1;
+
+ return ('SERVER', undef, undef, WF_ALL, undef, $1, $2, $6, $5, $3, $4);
+ # src, serverName, numHops, infoLine, serverNumeric, protocolVersion, buildFlags
+ }
+ elsif($_[0] =~ /^(:|@)(\S+) (?:SERVER|\') (\S+) (\d+) (\d+) :(.*)$/) {
+ # @38 SERVER test-hermes.surrealchat.net 2 100 :SurrealChat
+ # source, cmd, new server, hopCount, serverNumeric, infoLine
+ my ($numeric, $name);
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ create_server($3, $name);
+ $servernum[$5] = $3;
+
+ return ('SERVER', undef, undef, WF_ALL, $name, $3, $4, $6, $5);
+ # src, serverName, numHops, infoLine, serverNumeric
+ }
+ if($_[0] =~ /^(?:SERVER|\') (\S+) (\S+) :(.*)$/) {
+ $remoteserv = $1;
+ create_server($1);
+ return ('SERVER', undef, undef, WF_ALL, undef, $1, $2, $3);
+ # src, serverName, numHops, infoLine
+ }
+ elsif($_[0] =~ /^:(\S+) (?:SERVER|\') (\S+) (\d+) :(.*)$/) {
+ # source, new server, hop count, description
+ create_server($2, $1);
+ return ('SERVER', undef, undef, WF_ALL, $1, $2, $3, $4);
+ # src, serverName, numHops, infoLine
+ }
+}
+
+sub SQUIT($) {
+ if($_[0] =~ /^(?:SQUIT|-) (\S+) :(.*)$/) {
+ my $list = [get_server_children($1)];
+ set_server_state($1, undef());
+ return ('SQUIT', undef, undef, WF_ALL, undef, $list, $2);
+ }
+ elsif($_[0] =~ /^(:|@)(\S+) (?:SQUIT|-) (\S+) :(.*)$/) {
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ my $list = [get_server_children($3)];
+ set_server_state($3, undef());
+ return ('SQUIT', undef, undef, WF_ALL, $name, $list, $4);
+ }
+}
+
+sub NETINFO($) {
+ $_[0] =~ /^(?:NETINFO|AO) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) :(.*)$/;
+ return ('NETINFO', undef, undef, WF_NONE, $1, $2, $3, $4, $5, $6, $7, $8);
+}
+
+sub PROTOCTL($) {
+ $_[0] =~ /^PROTOCTL (.*)$/;
+ return ('PROTOCTL', undef, undef, WF_NONE, $1);
+}
+
+sub JOIN($) {
+ $_[0] =~ /^:(\S+) (?:C|JOIN) (\S+)$/;
+ return ('JOIN', undef, 1, WF_CHAN, $1, $2);
+}
+
+sub SJOIN($) {
+ if ($_[0] =~ /^(?:\~|SJOIN) (\S+) (\S+) (.*)$/) {
+ my ($ts, $cn, $payload) = ($1, $2, $3);
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ return ('SJOIN', undef, undef, WF_CHAN, parse_sjoin($remoteserv, $ts, $cn, $payload));
+ }
+ elsif($_[0] =~ /^(@|:)(\S+) (?:\~|SJOIN) (\S+) (\S+) (.*)$/) {
+ my ($server, $ts, $cn, $payload) = ($2, $3, $4, $5);
+ if ($1 eq '@') {
+ $server = $servernum[b64toi($2)];
+ }
+ else {
+ $server = $2;
+ }
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ return ('SJOIN', undef, undef, WF_CHAN, parse_sjoin($server, $ts, $cn, $payload));
+ }
+}
+
+sub PART($) {
+ if($_[0] =~ /^:(\S+) (?:D|PART) (\S+) :(.*)$/) {
+ return ('PART', undef, 0, WF_CHAN, $1, $2, $3);
+ }
+ elsif($_[0] =~ /^:(\S+) (?:D|PART) (\S+)$/) {
+ return ('PART', undef, 0, WF_CHAN, $1, $2, undef);
+ }
+}
+
+sub MODE($) {
+ if($_[0] =~ /^(@|:)(\S+) (?:G|MODE) (#\S+) (\S+) (.*)(?: \d+)?$/) {
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ return ('MODE', undef, 1, WF_ALL, $name, $3, $4, $5);
+ }
+ elsif($_[0] =~ /^:(\S+) (?:G|MODE) (\S+) :(\S+)$/) {
+ # We shouldn't ever get this, as UMODE2 is preferred
+ return ('UMODE', 0, 0, WF_ALL, $1, $3);
+ }
+
+}
+
+sub MESSAGE($) {
+ my ($event, @args);
+ if($_[0] =~ /^(@|:)(\S+) (?:\!|PRIVMSG) (\S+) :(.*)$/) {
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ $event = 'PRIVMSG'; @args = ($name, $3, $4);
+ }
+ elsif($_[0] =~ /^(@|:)(\S+) (?:B|NOTICE) (\S+) :(.*)$/) {
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ $event = 'NOTICE'; @args = ($name, $3, $4);
+ }
+ $args[1] =~ s/\@${main_conf{local}}.*//io;
+
+ if(queue_size > 50 and $event eq 'PRIVMSG' and $args[1] !~ /^#/ and $args[2] =~ /^\w/) {
+ ircd::notice($args[1], $args[0], "It looks like the system is busy. You don't need to do your command again, just hold on a minute...");
+ }
+
+ return ($event, 0, 1, WF_ALL, @args);
+}
+
+sub AWAY($) {
+ if($_[0] =~ /^:(\S+) (?:6|AWAY) :(.*)$/) {
+ return ('AWAY', undef, undef, WF_ALL, $1, $2);
+ }
+ elsif($_[0] =~ /^:(\S+) (?:6|AWAY) $/) {
+ return ('BACK', undef, undef, WF_ALL, $1);
+ }
+}
+
+sub NICK($) {
+ my ($event, @args);
+ if($_[0] =~ /^:(\S+) (?:NICK|\&) (\S+) :?(\S+)$/) {
+ return ('NICKCHANGE', undef, undef, WF_NICK, $1, $2, $3);
+ }
+ elsif(CLK && NICKIP && $_[0] =~ /^(?:NICK|\&) (\S+) (\d+) (\S+) (\S+) (\S+) (\S+) (\d+) (\S+) (\S+) (\S+) (\S+) :(.*)$/) {
+#NICK Guest57385 1 !14b7t0 northman tabriel.tabris.net 38 0 +iowghaAxNWzt netadmin.SCnet.ops SCnet-3B0714C4.tabris.net CgECgw== :Sponsored By Skuld
+#NICK outis 1 !14corv northman localhost 38 0 +iowghaAxNWzt tabris.netadmin.SCnet.ops SCnet-D8C01838 AAAAAAAAAAAAAAAAAAAAAQ== :Sponsored By Skuld
+ my ($nick, $hops, $ts, $ident, $host, $server, $stamp, $modes, $vhost, $cloakhost, $IP, $gecos) =
+ ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12);
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ if (SJB64 and length($server) <= 2 and $server !~ /\./) {
+ $server = $servernum[b64toi($server)];
+
+ }
+ if(main_conf_ipv6 && (length($IP) > 8)) {
+ $IP = Socket6::inet_ntop(AF_INET6, MIME::Base64::decode($IP));
+ } else {
+ $IP = join('.', unpack('C4', MIME::Base64::decode($IP)));
+ }
+ return ('NICKCONN', undef, undef, WF_NICK, $nick, $hops, $ts, $ident, $host, $server, $stamp, $modes, $vhost,
+ $gecos, $IP, $cloakhost
+ );
+ }
+ elsif(!CLK && NICKIP && $_[0] =~ /^(?:NICK|\&) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) :(.*)$/) {
+#NICK tab 1 1116196525 northman tabriel.tabris.net test-tab.surrealchat.net 0 +iowghaAxNWzt netadmin.SCnet.ops CgECgw== :Sponsored by Skuld
+ my ($nick, $hops, $ts, $ident, $host, $server, $stamp, $modes, $vhost, $IP, $gecos) =
+ ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11);
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ if (SJB64 and length($server) <= 2 and $server !~ /\./) {
+ $server = $servernum[b64toi($server)];
+
+ }
+ if(main_conf_ipv6 && length($IP) > 8) {
+ $IP = Socket6::inet_ntop(AF_INET6, MIME::Base64::decode($IP));
+ } else {
+ $IP = join('.', unpack('C4', MIME::Base64::decode($IP)));
+ }
+ return ('NICKCONN', undef, undef, WF_NICK, $nick, $hops, $ts, $ident, $host, $server, $stamp, $modes, $vhost,
+ $gecos, $IP
+ );
+ }
+ elsif(!CLK && !NICKIP && $_[0] =~ /^(?:NICK|\&) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) :(.*)$/) {
+#NICK tab 1 1116196525 northman tabriel.tabris.net test-tab.surrealchat.net 0 +iowghaAxNWzt netadmin.SCnet.ops :Sponsored by Skuld
+ my ($nick, $hops, $ts, $ident, $host, $server, $stamp, $modes, $vhost, $gecos) =
+ ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10);
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ if (SJB64 and length($server) <= 2 and $server !~ /\./) {
+ $server = $servernum[b64toi($server)];
+
+ }
+ return ('NICKCONN', undef, undef, WF_NICK, $nick, $hops, $ts, $ident, $host, $server, $stamp, $modes,
+ $vhost, $gecos);
+ }
+}
+
+sub QUIT($) {
+ $_[0] =~ /^:(\S+) (?:QUIT|\,) :(.*)$/;
+ return ('QUIT', 0, undef, WF_NICK, $1, $2);
+}
+
+sub KILL($) {
+#:tabris KILL ProxyBotW :tabris.netadmin.SCnet.ops!tabris (test.)
+#:ProxyBotW!bopm@ircop.SCnet.ops QUIT :Killed (tabris (test.))
+ $_[0] =~ /^(@|:)(\S+) (?:KILL|\.) (\S+) :(\S+) \((.*)\)$/;
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ return ('KILL', 0, 1, WF_NICK, $name, $3, $4, $5);
+}
+
+sub KICK($) {
+#:tabris KICK #diagnostics SurrealBot :i know you don't like this. but it's for science!
+ $_[0] =~ /^(@|:)(\S+) (?:KICK|H) (\S+) (\S+) :(.*)$/;
+ # source, chan, target, reason
+ #$src = 0; #$dst = 2;
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ return ('KICK', 0, undef, WF_CHAN, $name, $3, $4, $5);
+}
+
+sub HOST($) {
+ if($_[0] =~ /^:(\S+) (?:CHGHOST|AL) (\S+) (\S+)$/) {
+ #:Agent CHGHOST tabris tabris.netadmin.SCnet.ops
+ return ('CHGHOST', 0, 1, WF_CHAN, $1, $2, $3);
+ #setter, target, vhost
+ }
+ elsif($_[0] =~ /^:(\S+) (?:SETHOST|AA) (\S+)$/) {
+ #:tabris SETHOST tabris.netadmin.SCnet.ops
+ return ('CHGHOST', 0, 1, WF_CHAN, $1, $1, $2);
+ }
+
+ elsif ($_[0] =~ /^:(?:\S* )?302 (\S+) :(\S+?)\*?=[+-].*?\@(.*)/) {
+ #:serebii.razorville.co.uk 302 leif :Jesture=+~Jesture00@buzz-3F604D09.sympatico.ca
+ return ('CHGHOST', 0, 1, WF_CHAN, $1, $2, $3);
+ }
+}
+
+
+sub USERIP($) {
+ $_[0] =~ /^:(?:\S* )?340 (\S+) :(\S+?)\*?=[+-].*?\@((?:\.|\d)*)/;
+ return ('USERIP', 0, 1, WF_CHAN, $1, $2, $3);
+}
+
+sub IDENT($) {
+ if($_[0] =~ /^:(\S+) (?:CHGIDENT|AL) (\S+) (\S+)$/) {
+ return ('CHGIDENT', 0, 1, WF_ALL, $1, $2, $3);
+ #setter, target, IDENT
+ }
+ elsif($_[0] =~ /^:(\S+) (?:SETIDENT|AD) (\S+)$/) {
+ return ('CHGIDENT', 0, 1, WF_ALL, $1, $1, $2);
+ #setter, target, ident
+ }
+}
+
+
+sub TOPIC($) {
+ if($_[0] =~ /^(@|:)(\S+) (?:TOPIC|\)) (\S+) (\S+) (\S+) :(.*)$/) {
+ #:tabris TOPIC #the_lounge tabris 1089336598 :Small Channel in search of Strong Founder for long term relationship, growth, and great conversation.
+ my $name;
+ my ($name, $cn, $setter, $ts, $topic) = ($2, $3, $4, $5, $6);
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ return ('TOPIC', 0, 1, WF_ALL, $name, $cn, $setter, $ts, $topic);
+ }
+ elsif($_[0] =~ /^(?:TOPIC|\)) (\S+) (\S+) (\S+) :(.*)$/) {
+ my ($cn, $setter, $ts, $topic) = ($1, $2, $3, $4);
+ if ($ts =~ s/^!//) {
+ $ts = b64toi($ts);
+ }
+ # src, channel, setter, timestamp, topic
+ return ('TOPIC', 0, 1, WF_ALL, undef, $cn, $setter, $ts, $topic);
+ }
+}
+
+sub UMODE($) {
+#:tabris | +oghaANWt
+ $_[0] =~ /^:(\S+) (?:UMODE2|\|) (\S+)$/;
+ # src, umodes
+ # a note, not all umodes are passed
+ # +s, +O, and +t are not passed. possibly others
+ # also not all umodes do we care about.
+ # umodes we need care about:
+ # oper modes: hoaACN,O oper-only modes: HSq
+ # regular modes: rxB,izV (V is only somewhat, as the ircd
+ # does the conversions from NOTICE to PRIVSMG for us).
+
+ # Yes, I'm changing the event type on this
+ # It's better called UMODE, and easily emulated
+ # on IRCds with only MODE.
+ return ('UMODE', 0, 0, WF_ALL, $1, $2);
+}
+
+sub SVSMODE($) {
+#:tabris | +oghaANWt
+ $_[0] =~ /^:(\S+) (?:SVS2?MODE|n|v) (\S+) (\S+)$/;
+ # src, umodes
+ # a note, not all umodes are passed
+ # +s, +O, and +t are not passed. possibly others
+ # also not all umodes do we care about.
+ # umodes we need care about:
+ # oper modes: hoaACN,O oper-only modes: HSq
+ # regular modes: rxB,izV (V is only somewhat, as the ircd
+ # does the conversions from NOTICE to PRIVSMG for us).
+
+ return ('UMODE', 0, 0, WF_ALL, $2, $3);
+}
+
+sub WHOIS($) {
+# :tab WHOIS ConnectServ :ConnectServ
+ if($_[0] =~ /^:(\S+) (?:WHOIS|\#) (\S+)$/) {
+ return ('WHOIS', 0, undef, WF_NONE, $1, $2);
+ }
+ elsif($_[0] =~ /^:(\S+) (?:WHOIS|\#) (\S+) :(\S+)$/) {
+ return ('WHOIS', 0, undef, WF_NONE, $1, $3);
+ }
+}
+
+sub TSCTL($) {
+ $_[0] =~ /^:(\S+) (?:TSCTL|AW) alltime$/;
+ ircsend(":$main_conf{local} NOTICE $1 *** Server=$main_conf{local} TSTime=".
+ time." time()=".time." TSOffset=0");
+ return;
+}
+
+sub VERSION($) {
+ $_[0] =~ /^:(\S+) (?:VERSION|\+).*$/;
+ return ('VERSION', 0, undef, WF_NONE, $1);
+}
+
+sub TKL($) {
+ if ($_[0] =~ /^(@|:)(\S+) (?:TKL|BD) (.*)$/) {
+ # We discard the source anyway.
+ #my $server;
+ #if ($1 eq '@') {
+ # $server = $servernum[b64toi($2)];
+ #}
+ #else {
+ # $server = $2;
+ #}
+ return ('TKL', undef, undef, WF_NONE, parse_tkl("TKL $3"));
+ }
+ elsif ($_[0] =~ /^(?:TKL|BD) (.*)$/) {
+ return ('TKL', undef, undef, WF_NONE, parse_tkl("TKL $1"));
+ }
+}
+
+sub SNOTICE($) {
+ $_[0] =~ /^(@|:)(\S+) (SENDSNO|Ss|SMO|AU) ([A-Za-z]) :(.*)$/;
+ #@servernumeric Ss snomask :message
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ my $event;
+ $event = 'SENDSNO' if(($3 eq 'SENDSNO' or $3 eq 'Ss'));
+ $event = 'SMO' if(($3 eq 'SMO' or $3 eq 'AU'));
+ return ($event, 0, undef, WF_NONE, $name, $4, $5);
+}
+
+sub GLOBOPS($) {
+ $_[0] =~ /^(@|:)(\S+) (?:GLOBOPS|\]) :(.*)$/;
+ #@servernumeric [ :message
+ my $name;
+ if ($1 eq '@') {
+ $name = $servernum[b64toi($2)];
+ }
+ else {
+ $name = $2;
+ }
+ return ('GLOBOPS', 0, undef, WF_NONE, $name, $3);
+}
+
+sub ISUPPORT($) {
+ $_[0] =~ /^:(\S+) (?:105|005) (\S+) (.+) :are supported by this server$/;
+ # :test-tab.surrealchat.net 105 services.SC.net CMDS=KNOCK,MAP,DCCALLOW,USERIP :are supported by this server
+ foreach my $token (split(/\s+/, $3)) {
+ my ($key, $value) = split('=', $token);
+ $IRCd_capabilities{$key} = ($value ? $value : 1);
+ }
+}
+
+sub STATS($) {
+ $_[0] =~ /^:(\S+) (?:STATS|2) (\S) :(.+)$/;
+ return ('STATS', undef, undef, WF_NONE, $1, $2, $3)
+}
+
+BEGIN {
+ %cmdhash = (
+ PING => \&PING,
+ '8' => \&PING,
+
+ EOS => \&EOS,
+ ES => \&EOS,
+
+ SERVER => \&SERVER,
+ "\'" => \&SERVER,
+
+ SQUIT => \&SQUIT,
+ '-' => \&SQUIT,
+
+ NETINFO => \&NETINFO,
+ AO => \&NETINFO,
+
+ PROTOCTL => \&PROTOCTL,
+
+ JOIN => \&JOIN,
+ C => \&JOIN,
+
+ PART => \&PART,
+ D => \&PART,
+
+ SJOIN => \&SJOIN,
+ '~' => \&SJOIN,
+
+ MODE => \&MODE,
+ G => \&MODE,
+
+ PRIVMSG => \&MESSAGE,
+ '!' => \&MESSAGE,
+ NOTICE => \&MESSAGE,
+ B => \&MESSAGE,
+
+ AWAY => \&AWAY,
+ '6' => \&AWAY,
+
+ NICK => \&NICK,
+ '&' => \&NICK,
+
+ QUIT => \&QUIT,
+ ',' => \&QUIT,
+
+ KILL => \&KILL,
+ '.' => \&KILL,
+
+ KICK => \&KICK,
+ H => \&KICK,
+
+ CHGHOST => \&HOST,
+ AL => \&HOST,
+ SETHOST => \&HOST,
+ AA => \&HOST,
+ '302' => \&HOST,
+
+ '340' => \&USERIP,
+
+ CHGIDENT => \&IDENT,
+ AZ => \&IDENT,
+ SETIDENT => \&IDENT,
+ AD => \&IDENT,
+
+ TOPIC => \&TOPIC,
+ ')' => \&TOPIC,
+
+ UMODE2 => \&UMODE,
+ '|' => \&UMODE,
+
+ TSCTL => \&TSCTL,
+ AW => \&TSCTL,
+
+ VERSION => \&VERSION,
+ '+' => \&VERSION,
+
+ TKL => \&TKL,
+ BD => \&TKL,
+
+ WHOIS => \&WHOIS,
+ '#' => \&WHOIS,
+
+ SENDSNO => \&SNOTICE,
+ Ss => \&SNOTICE,
+
+ SMO => \&SNOTICE,
+ AU => \&SNOTICE,
+
+ GLOBOPS => \&GLOBOPS,
+ ']' => \&GLOBOPS,
+
+ '105' => \&ISUPPORT,
+ '005' => \&ISUPPORT,
+
+ SVSMODE => \&SVSMODE,
+ 'n' => \&SVSMODE,
+ SVS2MODE => \&SVSMODE,
+ 'v' => \&SVSMODE,
+
+ STATS => \&STATS,
+ '2' => \&STATS,
+ );
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package ircd;
+
+use strict;
+
+use IO::Socket::INET;
+use Event;
+use Carp;
+use MIME::Base64;
+
+use SrSv::Conf 'main';
+use SrSv::Conf::main;
+use SrSv::Conf2Consts qw( main );
+
+use SrSv::Debug;
+use SrSv::Log;
+
+# FIXME
+use constant {
+ MAXBUFLEN => 510,
+
+# These appear to match the implementations I've seen, but are unspecified in the RFCs.
+# They may vary by implementation.
+ NICKLEN => 30, # some ircds are different. hyperion is 16.
+ IDENTLEN => 10, # Sometimes 8 or 9.
+ # hyperion may break this due to it's ident format: [ni]=identhere, like this n=northman
+ HOSTLEN => 63, # I think I've seen 64 here before.
+ MASKLEN => 30 + 10 + 63 + 2, # 105, or maybe 106. the 2 constant is for !@
+
+ CHANNELLEN => 32, # From 005 reply. hyperion is 30.
+
+ SJ3 => 1,
+ NOQUIT => 1,
+ NICKIP => 1,
+ SJB64 => 1,
+ CLK => 1,
+
+ PREFIXAQ_DISABLE => 0,
+};
+die "NICKIP must be enabled if CLK is\n" if CLK && !NICKIP;
+
+use SrSv::IRCd::IO qw(ircd_connect ircsend ircsendimm ircd_flush_queue);
+use SrSv::IRCd::Event qw(addhandler callfuncs);
+use SrSv::IRCd::State qw($ircline $remoteserv $ircd_ready synced initial_synced set_server_state set_server_juped get_server_state get_online_servers);
+
+use SrSv::Unreal::Modes qw(@opmodes %opmodes $scm $ocm $acm);
+use SrSv::Unreal::Tokens qw( :tokens );
+use SrSv::IRCd::Parse qw(parse_tkl);
+use SrSv::Unreal::Base64 qw(itob64 b64toi);
+
+use SrSv::Text::Format qw( wordwrap );
+
+use SrSv::Agent;
+
+use SrSv::Process::InParent qw(update_userkill);
+
+our %defer_mode;
+our %preconnect_defer_mode;
+our @userkill;
+our $unreal_protocol_version;
+
+addhandler('SEOS', undef(), undef(), 'ircd::eos', 1);
+addhandler('NETINFO', undef(), undef(), 'ircd::netinfo', 1);
+addhandler('VERSION', undef(), undef(), 'ircd::version', 1);
+addhandler('SERVER', undef(), undef(), 'ircd::handle_server', 1);
+
+sub serv_connect() {
+ my $remote = main_conf_remote;
+ my $port = main_conf_port;
+
+ ircd_connect($remote, $port);
+
+ ircsendimm('PROTOCTL '.(main_conf_tokens ? 'TOKEN ' : '').'NICKv2 UMODE2 TKLEXT'.
+ (CLK ? ' CLK' : ' VHP'). # CLK obsoletes VHP. Plus if you leave VHP on, CLK doesn't work.
+ (NOQUIT ? ' NOQUIT' : '').(SJ3 ? ' SJOIN SJOIN2 SJ3' : '').
+ (NICKIP ? ' NICKIP' : '').
+ (SJB64 ? ' SJB64 NS VL' : ''),
+ 'PASS :'.main_conf_pass,
+ 'SERVER '.main_conf_local.' 1 '.main_conf_numeric.(SJB64 ? ( ':U*-*-'.main_conf_numeric.' ') : ' :').main_conf_info);
+
+ %preconnect_defer_mode = %defer_mode;
+ %defer_mode = ();
+}
+
+# Helper Functions
+
+sub handle_server($$$$;$$$) {
+# This is mostly a stub function, but we may need the $unreal_protocol_version
+# at a later date. Plus we may want to maintain a server tree in another module.
+ my ($src_server, $server_name, $num_hops, $info_line, $server_numeric, $protocol_version, $build_flags) = @_;
+ $unreal_protocol_version = $protocol_version if defined $protocol_version;
+}
+
+# Handler functions
+
+sub pong($$$) {
+ my ($src, $cookie, $dst) = @_;
+ # This will only make sense if you remember that
+ # $src is where it came from, $dst is where it went (us)
+ # we're basically bouncing it back, but changing from PING to PONG.
+ if (defined($dst) and defined($cookie)) {
+ # $dst is always $main_conf{local} anyway...
+ # this is only valid b/c we never have messages routed THROUGH us
+ # we are always an end point.
+ ircsendimm(":$dst @{[TOK_PONG]} $src :$cookie");
+ }
+ else {
+ ircsendimm("@{[TOK_PONG]} :$src");
+ }
+}
+
+sub eos {
+ print "GOT EOS\n\n" if DEBUG;
+
+ #foreach my $k (keys %servers) {
+ # print "Server: $k ircline: ",$servers{$k}[0], " state: ", $servers{$k}[1], "\n";
+ #}
+ #print "Synced: ", synced(), "\n\n";
+ #exit;
+
+ ircsendimm(':'.main_conf_local.' '.TOK_EOS, 'VERSION');
+
+ agent_sync();
+ flushmodes(\%preconnect_defer_mode);
+ ircd_flush_queue();
+
+ $ircd_ready = 1;
+}
+
+sub netinfo($$$$$$$$) {
+ ircsendimm(TOK_NETINFO.' 0 '.time." $_[2] $_[3] 0 0 0 :$_[7]");
+ $main_conf{network} = $_[7];
+}
+
+sub tssync {
+ ircsendimm((SJB64 ? '@'.itob64(main_conf_numeric) : ':'.main_conf_local)." @{[TOK_TSCTL]} SVSTIME ".time);
+}
+
+sub parse_sjoin($$$$) {
+ my ($server, $ts, $cn, $parms) = @_;
+ my (@users, @bans, @excepts, @invex, @blobs, $blobs, $chmodes, $chmodeparms);
+
+ $server = '' unless $server;
+
+ if($parms =~ /^:(.*)/) {
+ $blobs = $1;
+ } else {
+ ($chmodes, $blobs) = split(/ :/, $parms, 2);
+ ($chmodes, $chmodeparms) = split(/ /, $chmodes, 2);
+ }
+ @blobs = split(/ /, $blobs);
+
+ foreach my $x (@blobs) {
+ if($x =~ /^(\&|\"|\')(.*)$/) {
+ my $type;
+ push @bans, $2 if $1 eq '&';
+ push @excepts, $2 if $1 eq '"';
+ push @invex, $2 if $1 eq "\'";
+ } else {
+ $x =~ /^([*~@%+]*)(.*)$/;
+ my ($prefixes, $nick) = ($1, $2);
+ my @prefixes = split(//, $prefixes);
+ my $op;
+ foreach my $prefix (@prefixes) {
+ $op |= $opmodes{q} if ($prefix eq '*');
+ $op |= $opmodes{a} if ($prefix eq '~');
+ $op |= $opmodes{o} if ($prefix eq '@');
+ $op |= $opmodes{h} if ($prefix eq '%');
+ $op |= $opmodes{v} if ($prefix eq '+');
+ }
+
+ push @users, { NICK => $nick, __OP => $op };
+ }
+ }
+
+ return ($server, $cn, $ts, $chmodes, $chmodeparms, \@users, \@bans, \@excepts, \@invex);
+}
+
+# Send Functions
+
+sub kick($$$$) {
+ my ($src, $chan, $target, $reason) = @_;
+ $src = main_conf_local unless initial_synced();
+ ircsend(":$src @{[TOK_KICK]} $chan $target :$reason");
+# thread::ircrecv(":$src @{[TOK_KICK]} $chan $target :$reason");
+ callfuncs('KICK', 0, 2, [$src, $chan, $target, $reason]);
+}
+
+sub invite($$$) {
+ my ($src, $chan, $target) = @_;
+ #:SecurityBot INVITE tabris #channel
+ ircsend(":$src @{[TOK_INVITE]} $target $chan");
+}
+
+sub ping {
+# if(@_ == 1) {
+ ircsend(':'.main_conf_local.' '.TOK_PING.' :'.main_conf_local);
+# } else {
+# ircsend(':'.$_[2].' '.TOK_PONG.' '.$_[0].' :'.$_[1]);
+# }
+}
+
+sub __privmsg($$@) {
+ my ($src, $dst, @msgs) = @_;
+
+ my @bufs;
+ foreach my $buf (@msgs) {
+ # 3 spaces, two colons, PRIVMSG=7
+ # Length restrictions are for CLIENT Protocol
+ # hence the (MASKLEN - (NICKLEN + 1))
+ # Technically optimizable if we use $agent{lc $src}'s ident and host
+ my $buflen = length($src) + length($dst) + 5 + length(TOK_PRIVMSG) + (MASKLEN - (NICKLEN + 1));
+ push @bufs, wordwrap($buf, (MAXBUFLEN - $buflen));
+ }
+
+ # submit a list of messages as a single packet to the server
+ ircsend(":$src @{[TOK_PRIVMSG]} $dst :".join("\r\n".":$src @{[TOK_PRIVMSG]} $dst :", @bufs));
+ return \@bufs;
+}
+sub privmsg($$@) {
+ my ($src, $dst, @msgs) = @_;
+ my $bufs = __privmsg($src, $dst, @msgs);
+ callfuncs('LOOP_PRIVMSG', 0, 1, [$src, $dst, $bufs]);
+}
+sub privmsg_noloop($$@) {
+ my ($src, $dst, @msgs) = @_;
+ __privmsg($src, $dst, @msgs);
+ return;
+}
+
+sub debug(@) {
+ my (@msgs) = @_;
+ privmsg(main_conf_local, main_conf_diag, @msgs);
+ write_log('diag', '<'.main_conf_local.'>', @msgs);
+}
+
+sub debug_nolog(@) {
+ my (@msgs) = @_;
+ privmsg(main_conf_local, main_conf_diag, @msgs);
+}
+
+
+sub notice($$@) {
+ my ($src, $dst, @msgs) = @_;
+
+ my @bufs;
+ foreach my $buf (@msgs) {
+ # 3 spaces, two colons, NOTICE=6
+ # Length restrictions are for CLIENT Protocol
+ # hence the (MASKLEN - (NICKLEN + 1))
+ my $buflen = length($src) + length($dst) + 5 + length(TOK_NOTICE) + (MASKLEN - (NICKLEN + 1));
+ push @bufs, wordwrap($buf, (MAXBUFLEN - $buflen));
+ }
+
+ # submit a list of notices as a single packet to the server
+ ircsend(":$src @{[TOK_NOTICE]} $dst :".join("\r\n".":$src @{[TOK_NOTICE]} $dst :", @bufs));
+ callfuncs('LOOP_NOTICE', 0, 1, [$src, $dst, \@bufs]);
+}
+
+sub ctcp($$@) {
+ my ($src, $dst, $cmd, @toks) = @_;
+
+ privmsg($src, $dst, "\x01".join(' ', ($cmd, @toks))."\x01");
+}
+
+sub ctcp_reply($$@) {
+ my ($src, $dst, $cmd, @toks) = @_;
+
+ notice($src, $dst, "\x01".join(' ', ($cmd, @toks))."\x01");
+}
+
+sub setumode($$$) {
+ my ($src, $dst, $modes) = @_;
+
+ ircsend(":$src @{[TOK_SVS2MODE]} $dst $modes");
+ callfuncs('UMODE', 0, undef, [$dst, $modes]);
+}
+
+sub setsvsstamp($$$) {
+ my ($src, $dst, $stamp) = @_;
+
+ ircsend(":$src @{[TOK_SVS2MODE]} $dst +d $stamp");
+ # This function basically set the svsstamp to
+ # be the same as the userid. Not all ircd will
+ # support this function.
+ # We obviously already know the userid, so don't
+ # use a callback here.
+ #callfuncs('UMODE', 0, undef, [$dst, $modes]);
+}
+
+sub setagent_umode($$) {
+ my ($src, $modes) = @_;
+
+ ircsend(":$src @{[TOK_UMODE2]} $modes");
+}
+
+sub setmode2($$@) {
+ my ($src, $dst, @modelist) = @_;
+ #debug(" --", "-- ircd::setmode2: ".$_[0], split(/\n/, Carp::longmess($@)), " --");
+ foreach my $modetuple (@modelist) {
+ setmode($src, $dst, $modetuple->[0], $modetuple->[1]);
+ }
+}
+sub ban_list($$$$@) {
+# Convenience function for lots of bans or excepts.
+ my ($src, $cn, $sign, $mode, @parms) = @_;
+ my @masklist;
+ foreach my $mask (@parms) {
+ push @masklist, [( ($sign >= 1) ? '+' : '-').$mode, $mask];
+ }
+ ircd::setmode2($src, $cn, @masklist);
+}
+
+sub setmode($$$;$) {
+ my ($src, $dst, $modes, $parms) = @_;
+ $src = main_conf_local unless initial_synced();
+
+ callfuncs('MODE', undef, 1, [$src, $dst, $modes, $parms]);
+
+ print "$ircline -- setmode($src, $dst, $modes, $parms)\n" if DEBUG;
+ my $prev = $defer_mode{"$src $dst"}[-1];
+
+ if(defined($prev)) {
+ my ($oldmodes, $oldparms) = split(/ /, $prev, 2);
+
+ # 12 modes per line
+ if((length($oldmodes.$modes) - @{[($oldmodes.$modes) =~ /[+-]/g]}) <= 12 and length($src.$dst.$parms.$oldparms) < 400) {
+ $defer_mode{"$src $dst"}[-1] = modes::merge(
+ $prev, "$modes $parms", ($dst =~ /^#/ ? 1 : 0));
+ print $defer_mode{"$src $dst"}[-1], " *** \n" if DEBUG;
+
+ return;
+ }
+ }
+
+ push @{$defer_mode{"$src $dst"}}, "$modes $parms";
+}
+
+sub flushmodes(;$) {
+ my $dm = (shift or \%defer_mode);
+ my @k = keys(%$dm); my @v = values(%$dm);
+
+ for(my $i; $i<@k; $i++) {
+ my ($src, $dst) = split(/ /, $k[$i]);
+ my @m = @{$v[$i]};
+ foreach my $m (@m) {
+ my ($modes, $parms) = split(/ /, $m, 2);
+
+ setmode_real($src, $dst, $modes, $parms);
+ }
+ }
+
+ %$dm = ();
+}
+
+sub setmode_real($$$;$) {
+ my ($src, $dst, $modes, $parms) = @_;
+
+ print "$ircline -- setmode_real($src, $dst, $modes, $parms)\n" if DEBUG;
+ # for server sources, there must be a timestamp. but you can put 0 for unspecified.
+ $parms =~ s/\s+$//; #trim any trailing whitespace, as it might break the simple parser in the ircd.
+ ircsend(":$src @{[TOK_MODE]} $dst $modes".($parms?" $parms":'').($src =~ /\./ ? ' 0' : ''));
+}
+
+sub settopic($$$$$) {
+ my ($src, $chan, $setter, $time, $topic) = @_;
+ $src = main_conf_local unless initial_synced();
+
+ ircsend(":$src @{[TOK_TOPIC]} $chan $setter $time :$topic");
+ callfuncs('TOPIC', undef, undef, [$src, $chan, $setter, $time, $topic]);
+}
+
+sub wallops ($$) {
+ my ($src, $message) = @_;
+ ircsend(":$src @{[TOK_WALLOPS]} :$message");
+}
+
+sub globops ($$) {
+ my ($src, $message) = @_;
+ ircsend(":$src @{[TOK_GLOBOPS]} :$message");
+}
+
+sub kline ($$$$$) {
+ my ($setter, $ident, $host, $expiry, $reason) = @_;
+ $setter=main_conf_local unless defined($setter);
+ $ident = '*' unless defined($ident);
+
+
+ #foreach my $ex (@except) { return 1 if $mask =~ /\Q$ex\E/i; }
+
+ #my $line = "GLINE $mask $time :$reason";
+ # you need to use TKL for this. GLINE is a user command
+ # TKL is a server command.
+ # format is
+ # TKL +/- type ident host setter expiretime settime :reason
+#:nascent.surrealchat.net TKL + G * *.testing.only tabris!northman@netadmin.SCnet.ops 1089168439 1089168434 :This is just a test.
+ my $line = "TKL + G $ident $host $setter ".($expiry + time()).' '.time()." :$reason";
+
+ ircsend($line);
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub unkline ($$$) {
+ my ($setter, $ident, $host) = @_;
+ # TKL - G ident host setter
+# TKL - G ident *.test.dom tabris!northman@netadmin.SCnet.ops
+ my $line = "TKL - G $ident $host $setter";
+ ircsend($line);
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub zline ($$$$) {
+ my ($setter, $host, $expiry, $reason) = @_;
+ $setter=main_conf_local unless defined($setter);
+
+ #foreach my $ex (@except) { return 1 if $mask =~ /\Q$ex\E/i; }
+
+ # format is
+ # TKL +/- type ident host setter expiretime settime :reason
+ my $line = "TKL + Z * $host $setter ".($expiry + time).' '.time." :$reason";
+ ircsend($line);
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub unzline ($$) {
+ my ($setter, $host) = @_;
+ # TKL - G ident host setter
+# TKL - G ident *.test.dom tabris!northman@netadmin.SCnet.ops
+ my $line = "TKL - Z * $host $setter";
+ ircsend($line);
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub spamfilter($$$$$$$) {
+# Note the hardcoded zero (0).
+# Looks like theoretically one can have expirable spamfilters.
+# This is untested however.
+ my ($sign, $tkl_target, $tkl_action, $setter, $bantime, $reason, $regex) = @_;
+ my $tkl = "TKL ".($sign ? '+' : '-' )." F $tkl_target $tkl_action $setter 0 ".time()." $bantime $reason :$regex";
+ ircsend($tkl);
+ callfuncs('TKL', undef, undef, [parse_tkl($tkl)]);
+}
+
+sub update_userkill($) {
+ my ($target) = @_;
+
+ # This is a simple way to do it, that _could_ be defeated
+ # with enough users getting killed at once.
+ # The alternative would require a timer to expire the old entries.
+ return undef if (time() == $userkill[1] and $target eq $userkill[0]);
+ @userkill = ($target, time());
+
+ return 1;
+}
+
+sub irckill($$$) {
+ my ($src, $targetlist, $reason) = @_;
+ $src = main_conf_local unless initial_synced();
+
+ foreach my $target (split(',', $targetlist)) {
+ next unless update_userkill($target);
+
+ ircsendimm(":$src @{[TOK_KILL]} $target :$src ($reason)");
+
+ callfuncs('KILL', 0, 1, [$src, $target, $src, $reason]);
+ }
+}
+
+sub svssno($$$) {
+ my ($src, $target, $snomasks) = @_;
+ $src=main_conf_local unless defined($src);
+ # TODO:
+ # None, this doesn't affect us.
+
+ # SVSSNO is not in tokens.txt nor msg.h
+ ircsend(":$src ".'SVS2SNO'." $target $snomasks ".time);
+}
+
+sub svsnick($$$) {
+ my ($src, $oldnick, $newnick) = @_;
+ $src=main_conf_local unless defined($src);
+ # note: we will get a NICK cmd back after a
+ # successful nick change.
+ # warning, if misused, this can KILL the user
+ # with a collision
+
+# ircsend(":$src @{[TOK_SVSNICK]} $oldnick $newnick ".time);
+ ircsend("@{[TOK_SVSNICK]} $oldnick $newnick :".time);
+}
+
+sub svsnoop($$$) {
+ my ($targetserver, $bool, $src) = @_;
+ $src = main_conf_local unless defined($src);
+ if ($bool > 0) { $bool = '+'; } else { $bool = '-'; }
+#this is SVS NO-OP not SVS SNOOP
+ ircsend(":@{[main_conf_local]} @{[TOK_SVSNOOP]} $targetserver $bool");
+}
+
+sub svswatch ($$@) {
+# Changes the WATCH list of a user.
+# Syntax: SVSWATCH <nick> :<watch parameters>
+# Example: SVSWATCH Blah :+Blih!*@* -Bluh!*@* +Bleh!*@*.com
+# *** We do not track this info nor care.
+ my ($src, $target, @watchlist) = @_;
+ my $base_str = ":$src @{[TOK_SVSWATCH]} $target :";
+ my $send_str = $base_str;
+ while (@watchlist) {
+ my $watch = shift @watchlist;
+ if (length("$send_str $watch") > MAXBUFLEN) {
+ ircsend($send_str);
+ $send_str = $base_str;
+ }
+ $send_str = "$send_str $watch";
+ }
+ ircsend($send_str);
+}
+
+sub svssilence ($$@) {
+# Changes the SILENCE list of a user.
+# Syntax: SVSSILENCE <nick> :<silence parameters>
+# Example: SVSSILENCE Blah :+Blih!*@* -Bluh!*@* +Bleh!*@*.com
+# *** We do not track this info nor care.
+ my ($src, $target, @silencelist) = @_;
+ my $base_str = ":$src @{[TOK_SVSSILENCE]} $target :";
+ my $send_str = $base_str;
+ while (@silencelist) {
+ my $silence = shift @silencelist;
+ if (length("$send_str $silence") > MAXBUFLEN) {
+ ircsend($send_str);
+ $send_str = $base_str;
+ }
+ $send_str = "$send_str $silence";
+ }
+ ircsend($send_str);
+}
+
+sub svso($$$) {
+# Gives nick Operflags like the ones in O:lines.
+# SVSO <nick> <+operflags> (Adds the Operflags)
+# SVSO <nick> - (Removes all O:Line flags)
+# Example: SVSO SomeNick +bBkK
+# *** We do not track this info nor care.
+# *** We will see any umode changes later.
+# *** this cmd does not change any umodes!
+
+ my ($src, $target, $oflags) = @_;
+ $src = main_conf_local unless defined($src);
+ ircsend(":$src @{[TOK_SVSO]} $target $oflags");
+
+}
+
+sub swhois($$$) {
+# *** We do not track this info nor care.
+ my ($src, $target, $swhois) = @_;
+ $src = main_conf_local unless defined($src);
+ ircsend(":$src @{[TOK_SWHOIS]} $target :$swhois");
+}
+
+sub svsjoin($$@) {
+ my ($src, $target, @chans) = @_;
+ while(my @chanList = splice(@chans, 0, 10)) {
+ # split into no more than 10 at a time.
+ __svsjoin($src, $target, @chanList);
+ }
+}
+
+sub __svsjoin($$@) {
+ my ($src, $target, @chans) = @_;
+ # a note. a JOIN is returned back to us on success
+ # so no need to process this command.
+ # similar for svspart.
+ ircsend(($src?":$src":'')." @{[TOK_SVSJOIN]} $target ".join(',', @chans));
+}
+
+sub svspart($$$@) {
+ my ($src, $target, $reason, @chans) = @_;
+ ircsend(($src ? ":$src" : '')." @{[TOK_SVSPART]} $target ".join(',', @chans).
+ ($reason ? " :$reason" : ''));
+}
+
+sub sqline ($;$) {
+# we need to sqline most/all of our agents.
+# tho whether we want to put it in agent_connect
+# or leave it to the module to call it...
+ my ($nickmask, $reason) = @_;
+ #ircsend("@{[TOK_SQLINE]} $nickmask".($reason?" :$reason":''));
+ qline($nickmask, 0, $reason);
+}
+
+sub svshold($$$) {
+# Not all IRCd will support this command, as such the calling module must check the IRCd capabilities first.
+ my ($nickmask, $expiry, $reason) = @_;
+# TKL version - Allows timed qlines.
+# TKL + Q * test services.SC.net 0 1092179497 :test
+ my $line = 'TKL + Q H '.$nickmask.' '.main_conf_local.' '.($expiry ? $expiry+time() : 0).' '.time().' :'.$reason;
+ ircsend($line);
+
+ # at startup we send these too early,
+ # before the handlers are initialized
+ # so they may be lost.
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub svsunhold($) {
+ my ($nickmask) = @_;
+# TKL version
+# TKL - Q * test services.SC.net
+ my $line = 'TKL - Q H '.$nickmask.' '.main_conf_local;
+ ircsend($line);
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub qline($$$) {
+ my ($nickmask, $expiry, $reason) = @_;
+# TKL version - Allows timed qlines.
+# TKL + Q * test services.SC.net 0 1092179497 :test
+ my $line = 'TKL + Q * '.$nickmask.' '.main_conf_local.' '.($expiry ? $expiry+time() : 0).' '.time().' :'.$reason;
+ ircsend($line);
+
+ # at startup we send these too early,
+ # before the handlers are initialized
+ # so they may be lost.
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub unsqline ($) {
+# we need to sqline most/all of our agents.
+# tho whether we want to put it in agent_connect
+# or leave it to the module to call it...
+ my ($nickmask) = @_;
+ unqline($nickmask);
+}
+
+sub unqline($) {
+ my ($nickmask) = @_;
+# TKL version
+# TKL - Q * test services.SC.net
+ my $line = 'TKL - Q * '.$nickmask.' '.main_conf_local;
+ ircsend($line);
+ callfuncs('TKL', undef, undef, [parse_tkl($line)]);
+}
+
+sub svskill($$$) {
+ my ($src, $target, $reason) = @_;
+ # SVSKILL requires a src, it will NOT work w/o one.
+ # not sure if it'll accept a servername or not.
+ # consider defaulting to ServServ
+ die('svskill called w/o $src') unless $src;
+ ircsend(':'.$src.' '.TOK_SVSKILL.' '.$target.' :'.$reason);
+ callfuncs('QUIT', 0, undef, [$target, $reason]);
+}
+
+sub version($) {
+ my ($src) = @_;
+ ircsend(":@{[main_conf_local]} 351 $src $main::progname ver $main::version @{[main_conf_local]} ".
+ $main::extraversion);
+}
+
+sub userhost($) {
+ my ($target) = @_;
+ ircsend("@{[TOK_USERHOST]} $target");
+}
+
+sub userip($) {
+ my ($target) = @_;
+ die "We're not supposed to use USERIP anymore!" if DEBUG and NICKIP;
+ ircsend(":$main::rsnick USERIP $target");
+}
+
+sub chghost($$$) {
+ my ($src, $target, $vhost) = @_;
+ ircsend(($src?":$src ":'')."@{[TOK_CHGHOST]} $target $vhost");
+ callfuncs('CHGHOST', 0, 1, [$src, $target, $vhost]);
+}
+
+sub chgident($$$) {
+ my ($src, $target, $ident) = @_;
+ ircsend(($src?":$src ":'')."@{[TOK_CHGIDENT]} $target $ident");
+ callfuncs('CHGIDENT', 0, 1, [$src, $target, $ident]);
+}
+
+sub jupe_server($$) {
+ my ($server, $reason) = @_;
+
+ # :nascent.surrealchat.net SERVER wyvern.surrealchat.net 2 :SurrealChat
+ die "You can't jupe $server"
+ if ((lc($server) eq lc($remoteserv)) or (lc($server) eq lc(main_conf_local)));
+ ircsend(':'.main_conf_local.' '."@{[TOK_SQUIT]} $server :");
+ ircsend(':'.main_conf_local.' '."@{[TOK_SERVER]} $server 2 :$reason");
+
+ set_server_juped($server);
+}
+
+sub rehash_all_servers(;$) {
+ my ($type) = @_;
+
+ # Validate the type before passing it along.
+ # Very IRCd specific! May be version specific.
+ $type = undef() if(defined($type) && !($type =~ /^\-(motd|botmotd|opermotd|garbage)$/i));
+
+ foreach my $server (get_online_servers()) {
+ ircsend(':'.$main::rsnick.' '.TOK_REHASH.' '.$server.(defined($type) ? ' '.$type : '') );
+ }
+}
+
+sub unban_nick($$@) {
+# This is an Unreal-specific server-protocol HACK.
+# It is not expected to be portable to other ircds.
+# Similar concepts may exist in other ircd implementations
+ my ($src, $cn, @nicks) = @_;
+
+ my $i = 0; my @nicklist = ();
+ while(my $nick = shift @nicks) {
+ push @nicklist, $nick;
+ if(++$i >= 10) {
+ ircsend(($src ? ":$src " : '' )."@{[TOK_SVSMODE]} $cn -".'b'x($i).' '.join(' ', @nicklist));
+ $i = 0; @nicklist = ();
+ }
+ }
+
+ ircsend(($src ? ":$src " : '' )."@{[TOK_SVSMODE]} $cn -".'b'x($i).' '.join(' ', @nicklist));
+ # We don't loopback this, as we'll receive back the list
+ # of removed bans.
+}
+
+sub clear_bans($$) {
+# This is an Unreal-specific server-protocol HACK.
+# It is not expected to be portable to other ircds.
+# Similar concepts may exist in other ircd implementations
+ my ($src, $cn) = @_;
+
+ ircsend(($src ? ":$src " : '' )."@{[TOK_SVSMODE]} $cn -b");
+ # We don't loopback this, as we'll receive back the list
+ # of removed bans.
+}
+
+# HostServ OFF would want this.
+# resets the vhost to be the cloakhost.
+sub reset_cloakhost($$) {
+ my ($src, $target) = @_;
+ setumode($src, $target, '-x+x'); # only works in 3.2.6.
+}
+
+# removes the cloakhost, so that vhost matches realhost
+sub disable_cloakhost($$) {
+ my ($src, $target) = @_;
+ setumode($src, $target, '-x'); # only works in 3.2.6.
+}
+
+# enables the cloakhost, so that vhost becomes the cloakhost
+sub enable_cloakhost($$) {
+ my ($src, $target) = @_;
+ setumode($src, $target, '+x'); # only works in 3.2.6.
+}
+
+sub nolag($$@) {
+ my ($src, $sign, @targets) = @_;
+ $src = main_conf_local unless $src;
+ foreach my $target (@targets) {
+ ircsend(':'.$src .' '.TOK_SVS2NOLAG.' '.$sign.' '.$target);
+ }
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Unreal::Tokens;
+
+use strict;
+
+use SrSv::Conf::main;
+use SrSv::Conf2Consts qw( main );
+
+use Exporter 'import';
+
+#=cut
+our $tkn = main_conf_tokens;
+
+our %tkn;
+#=cut
+BEGIN {
+# TODO: Turn these into constants.
+my %unrealTokens = (
+ PRIVMSG => ['PRIVMSG', '!'],
+ WHOIS => ['WHOIS', '#'],
+ WHOWAS => ['WHOWAS', '$'],
+ USER => ['USER', '%'],
+ NICK => ['NICK', '&'],
+ SERVER => ['SERVER', "\'"],
+ LIST => ['LIST', '('],
+ TOPIC => ['TOPIC', ')'],
+ INVITE => ['INVITE', '*'],
+ VERSION => ['VERSION', '+'],
+ QUIT => ['QUIT', ','],
+ SQUIT => ['SQUIT', '-'],
+ KILL => ['KILL', '.'],
+ INFO => ['INFO', '/'],
+ LINKS => ['LINKS', '0'],
+ STATS => ['STATS', '2'],
+ USERS => ['USERS', '3'],
+ ERROR => ['ERROR', '5'],
+ AWAY => ['AWAY', '6'],
+ CONNECT => ['CONNECT', '7'],
+ PING => ['PING', '8'],
+ PONG => ['PONG', '9'],
+ OPER => ['OPER', ';'],
+ PASS => ['PASS', '<'],
+ WALLOPS => ['WALLOPS', '='],
+ GLOBOPS => ['GLOBOPS', ']'],
+ TIME => ['TIME', '>'],
+ NAMES => ['NAMES', '?'],
+ SJOIN => ['SJOIN', '~'],
+ NOTICE => ['NOTICE', 'B'],
+ JOIN => ['JOIN', 'C'],
+ PART => ['PART', 'D'],
+ MODE => ['MODE', 'G'],
+ KICK => ['KICK', 'H'],
+ USERHOST => ['USERHOST', 'J'],
+ SQLINE => ['SQLINE', 'c'],
+ UNSQLINE => ['UNSQLINE', 'd'],
+ SVSNICK => ['SVSNICK', 'e'],
+ SVSNOOP => ['SVSNOOP', 'f'],
+ SVSKILL => ['SVSKILL', 'h'],
+ SVSMODE => ['SVSMODE', 'n'],
+ SVS2MODE => ['SVS2MODE', 'v'],
+ CHGHOST => ['CHGHOST', 'AL'],
+ CHGIDENT => ['CHGIDENT', 'AZ'],
+ NETINFO => ['NETINFO', 'AO'],
+ TSCTL => ['TSCTL', 'AW'],
+ SWHOIS => ['SWHOIS', 'BA'],
+ SVSO => ['SVSO', 'BB'],
+ # One may note... that although there is a TKL Token
+ # it does not appear to always be used.
+ # Maybe b/c 2 vs 3 chars, nobody cares.
+ TKL => ['TKL', 'BD'],
+ SHUN => ['SHUN', 'BL'],
+ SVSJOIN => ['SVSJOIN', 'BX'],
+ SVSPART => ['SVSPART', 'BT'],
+ SVSSILENCE => ['SVSSILENCE','Bs'],
+ SVSWATCH => ['SVSWATCH', 'Bw'],
+ SVSSNO => ['SVSSNO', 'BV'],
+ SENDSNO => ['SENDSNO', 'Ss'],
+
+ EOS => ['EOS', 'ES'],
+ UMODE2 => ['UMODE2', "\|"],
+
+ REHASH => ['REHASH', 'O'],
+
+ SVSNOLAG => ['SVSNOLAG', 'sl'],
+ SVS2NOLAG => ['SVS2NOLAG', 'SL'],
+);
+
+ %tkn = %unrealTokens;
+ my %msgs; map { $msgs{"MSG_$_"} = $unrealTokens{$_}->[0] } keys(%unrealTokens);
+ my %toks;
+ if(main_conf_tokens) {
+ map { $toks{"TOK_$_"} = $unrealTokens{$_}->[1] } keys(%unrealTokens);
+ } else {
+ map { $toks{"TOK_$_"} = $unrealTokens{$_}->[0] } keys(%unrealTokens);
+ }
+ require constant;
+ import constant \%toks;
+ import constant \%msgs;
+
+ our @EXPORT_OK = (
+ keys(%toks),
+ keys(%msgs),
+ qw( %tkn $tkn )
+ );
+ our %EXPORT_TAGS = (
+ tokens => [keys(%toks)],
+ messages => [keys(%msgs)],
+ );
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::IRCd::Validate;
+
+use SrSv::HostMask qw( normalize_hostmask );
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT_OK = qw(valid_server valid_nick validate_chmodej validate_chmodef validate_chmodes validate_ban); }
+
+our $valid_nick_re = qr/^[][a-zA-Z`\\\|{}_^][][a-zA-Z0-9`\\\|{}_^-]*$/;
+
+our $s_chars = qr/[a-zA-Z0-9_.-]/;
+our $valid_server_re = qr/^[a-zA-Z]$s_chars*\.$s_chars*$/;
+
+sub valid_server($) {
+ return $_[0] =~ $valid_server_re;
+}
+
+sub valid_nick($) {
+ return $_[0] =~ $valid_nick_re;
+}
+
+sub validate_chmodej($) {
+ my ($joins, $seconds) = split(/:/, @_);
+ return 1 unless (defined $joins and ($joins <= 255 and $joins >=1));
+ return 1 unless (defined $seconds and ($seconds <= 999 and $seconds >=1));
+ return 0;
+}
+
+my %chmodef_types = (
+ c => [{'m' => 1, 'M' => 1}, 0, 60],
+ j => [{'R' => 1}, 0, 60],
+ k => [{'K' => 1}, 0, 60],
+ m => [{'M' => 1}, 0, 60],
+ n => [{'N' => 1}, 0, 60],
+ t => [{'b' => 1}, -1],
+);
+
+sub validate_chmodef($) {
+ my ($block, $seconds) = split(/:/, $_[0]);
+ # [4j#i5,3k#K7,15m#M10,5n#N5,6t#b]:5
+
+ return 0 unless (defined($seconds) and ($seconds <= 999 and $seconds > 0));
+
+ $block =~ s/(\[|\])//g;
+
+ foreach my $tuple (split(',', $block)) {
+ my ($limit, $action) = split('#', $tuple);
+ my ($type, $time);
+ {
+ $limit =~ /([0-9]{1,3})([a-z])$/;
+ ($time, $type) = ($1, $2);
+ }
+ return 0 unless defined($chmodef_types{$type});
+
+ my $restrictions = $chmodef_types{$type};
+ if($restrictions == -1) {
+ return 0 if defined($action);
+ } else {
+ my ($alt, $time) = split(//, $action, 2);
+ return 0 if (defined($action) and $restrictions->[0]->{$a});
+ }
+ }
+ return 1;
+}
+
+sub validate_chmodes($@) {
+ my ($modes_in, @parms_in) = @_;
+ my ($modes_out, @parms_out);
+ my $sign = '+';
+ foreach my $mode (split(//, $modes_in)) {
+ my $parm;
+ if ($mode =~ /^[+-]$/) {
+ $sign = $mode;
+ }
+ elsif ($mode =~ /^[qaohv]$/) {
+ $parm = shift @parms_in;
+ unless(valid_nick($parm)) {
+ next;
+ }
+ }
+ else {
+ $parm = shift @parms_in if $mode =~ /^[beIkflLj]$/;
+ ($mode, $parm) = validate_chmode($mode, $sign, $parm);
+ }
+ push @parms_out, $parm if $parm;
+ $modes_out .= $mode;
+ }
+ return ($modes_out, @parms_out);
+}
+
+sub validate_extban($) {
+# Unreal 3.3 will have chained extbans.
+ my ($parm) = @_;
+ my ($type, $payload) = split(':', $parm, 2);
+ $type =~ s/^\~//;
+ if($type eq 'q' or $type eq 'n') {
+ return 1 if($payload =~ /^(.+)!(.+)@(.+)$/);
+ } elsif($type eq 'c') {
+ return 1 if($payload =~ /^[~&@%+]?#.{0,29}$/);
+ } elsif($type eq 'r') {
+ return 1; # how can this be invalid anyway?
+ } elsif($type eq 'T') {
+ my ($action, $mask) = split(':', $payload);
+ return 1 if ($action =~ /^(block|censor)$/i);
+ }
+}
+
+sub validate_ban($) {
+ my ($parm) = @_;
+ if($parm =~ /^(.+)!(.+)@(.+)$/) {
+ # nothing obviously wrong
+ return $parm;
+ }
+ elsif($parm =~ /^\~[qncrT]:/i) {
+ # nothing obviously wrong
+ # or at least, we know nothing about it.
+ return $parm if validate_extban($parm);
+ } else {
+ # hopefully this will sufficiently sanitize it for the ircd.
+ # if this is wrong, it may cause desyncs in the ban list.
+ # thankfully most of those should be invalid bans and won't match on anything.
+ return normalize_hostmask($parm);
+ }
+ return undef;
+}
+
+sub validate_chmode($$;$) {
+ my ($mode, $sign, $parm) = @_;
+ use Switch;
+ switch($mode) {
+ #CHANMODES=beI,kfL,lj,psmntirRcOAQKVCuzNSMTG
+ case /^[beI]$/ {
+ $parm = validate_ban($parm);
+ return ($mode, $parm) if $parm;
+ }
+ case 'f' {
+ return ($mode, $parm) if $sign eq '-' or validate_chmodef($parm);
+ }
+ case 'k' {
+ $parm = '*' if $sign eq '-' and !defined($parm);
+ return ($mode, $parm)
+ }
+ case 'l' {
+ $parm = '1' if $sign eq '-' and !defined($parm);
+ return ($mode, $parm) if $parm =~ /^\d+$/;
+ }
+ case 'L' {
+ $parm = '*' if $sign eq '-' and !defined($parm);
+ return ($mode, $parm) if $parm =~ /^#/;
+ }
+ case 'j' {
+ return ($mode, $parm) if validate_chmodej($parm);
+ }
+ case /^[psmntirRcOAQKVCuzNSMTG]$/ { return ($mode, undef); }
+ else { return undef; }
+ }
+}
+
+1;
--- /dev/null
+package SrSv::Upgrade::HashPass;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw(hash_all_passwords) }
+
+use SrSv::Hash::SaltedHash;
+use SrSv::Hash::Passwords qw( hash_pass validate_pass is_hashed );
+use SrSv::MySQL '$dbh';
+use SrSv::Process::Init;
+use SrSv::Conf 'main';
+
+my ($get_nicks, $replace_pass);
+
+proc_init {
+ $get_nicks = $dbh->prepare("SELECT nick, id, pass FROM nickreg ORDER BY id");
+ $replace_pass = $dbh->prepare("UPDATE nickreg SET pass=? WHERE id=?");
+};
+
+sub hash_all_passwords() {
+ return unless $main_conf{'hashed-passwords'};
+
+ print "Updating passwords...\n";
+
+ $dbh->do("LOCK TABLES nickreg WRITE");
+
+ $get_nicks->execute();
+ while (my ($nick, $nrid, $pass) = $get_nicks->fetchrow_array() ) {
+ next if is_hashed($pass);
+
+ my $hashedPass = hash_pass($pass);
+
+ #print STDOUT "$nick, $nrid, $pass, $hashedPass\n";
+ #print STDOUT (validate_pass($hashedPass, $pass) ? "hash is valid" : "hash is not valid" )."\n";
+ #print STDOUT " ----------------- \n";
+ validate_pass($hashedPass, $pass) or die "Internal error while converting password ($pass, $hashedPass)";
+
+ $replace_pass->execute($hashedPass, $nrid);
+ }
+
+ $dbh->do("UNLOCK TABLES");
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::User;
+
+=head1 NAME
+
+SrSv::User - Track users
+
+=head1 SYNOPSIS
+
+ use SrSv::User qw(get_user_id get_user_nick get_user_agent is_online chk_online get_user_flags set_user_flag chk_user_flag);
+
+=cut
+
+use strict;
+
+use Exporter 'import';
+BEGIN {
+ my %constants = (
+ UF_FINISHED => 1,
+ UF_GUEST => 2,
+ );
+
+ our @EXPORT_OK = (qw(get_user_id get_user_nick get_user_agent is_online chk_online
+ $get_user_id $get_user_nick
+ get_user_ip
+ get_user_flags set_user_flag chk_user_flag set_user_flag_all
+ get_host get_vhost get_cloakhost get_user_info
+ flood_inc flood_check get_flood_level
+ kill_user kline_user
+ __flood_expire
+ ),
+ keys(%constants));
+ my @flood = qw( flood_inc flood_check get_flood_level );
+ my @flags = qw( get_user_flags set_user_flag chk_user_flag set_user_flag_all );
+ our %EXPORT_TAGS = (
+ flags => [keys(%constants)],
+ flood => [@flood],
+ user_flags => [@flags],
+ );
+
+ require constant; import constant (\%constants);
+}
+
+use SrSv::MySQL::Stub {
+ __getIP => ['ROW', "SELECT INET_NTOA(ip), ipv6 FROM user WHERE id=?"],
+};
+
+
+
+use SrSv::IRCd::Send; #package ircd
+use SrSv::Process::Init;
+use SrSv::MySQL '$dbh';
+use SrSv::NickControl::Enforcer qw(%enforcers);
+use SrSv::IRCd::State qw(synced);
+use SrSv::Agent qw(is_agent);
+use SrSv::User::Notice;
+
+use SrSv::Conf::services;
+use SrSv::Conf::main;
+use SrSv::Conf2Consts qw( main services );
+
+use SrSv::IPv6;
+
+use SrSv::Log;
+
+our (
+ $get_user_id, $get_user_nick, $get_nickchg, $is_online,
+
+ $get_user_flags, $set_user_flag, $unset_user_flag, $set_user_flag_all,
+
+ $get_host, $get_vhost, $get_cloakhost,
+);
+
+proc_init {
+ $get_user_id = $dbh->prepare("SELECT id FROM user WHERE nick=?");
+ $get_user_nick = $dbh->prepare("SELECT nick FROM user WHERE id=?");
+ $get_nickchg = $dbh->prepare("SELECT nickchg.nickid, user.nick FROM nickchg, user WHERE user.id=nickchg.nickid AND nickchg.nick=?");
+ $is_online = $dbh->prepare("SELECT 1 FROM user WHERE nick=? AND online=1");
+
+ $get_user_flags = $dbh->prepare("SELECT flags FROM user WHERE id=?");
+ $set_user_flag = $dbh->prepare("UPDATE user SET flags=(flags | (?)) WHERE id=?");
+ $unset_user_flag = $dbh->prepare("UPDATE user SET flags=(flags & ~(?)) WHERE id=?");
+ $set_user_flag_all = $dbh->prepare("UPDATE user SET flags=flags | ?");
+
+ $get_host = $dbh->prepare("SELECT ident, host FROM user WHERE id=?");
+ $get_vhost = $dbh->prepare("SELECT ident, vhost FROM user WHERE id=?");
+ $get_cloakhost = $dbh->prepare("SELECT 1, cloakhost FROM user WHERE id=?");
+};
+require SrSv::MySQL::Stub;
+import SrSv::MySQL::Stub {
+ __flood_check => ['SCALAR', "SELECT flood FROM user WHERE id=?"],
+ __flood_inc => ['NULL', "UPDATE user SET flood = flood + ? WHERE id=?"],
+ __flood_expire => ['NULL', "UPDATE user SET flood = flood >> 1"], # shift is faster than mul
+
+ __get_user_info => ['ROW', "SELECT ident, host, vhost, gecos, server, time, quittime
+ FROM user WHERE id=?"],
+};
+
+sub get_flood_level($) {
+ my ($user) = @_;
+
+ if(defined($user->{FLOOD})) {
+ return $user->{FLOOD};
+ }
+ my $flev = __flood_check(get_user_id($user));
+ $user->{FLOOD} = $flev;
+ return $flev;
+}
+
+sub flood_inc($;$) {
+ my ($user, $amount) = @_;
+ $amount = 1 unless defined($amount);
+
+ get_flood_level($user);
+ $user->{FLOOD} += $amount;
+ __flood_inc($amount, get_user_id($user));
+ return $user->{FLOOD};
+}
+
+sub flood_check($;$) {
+ my ($user, $amount) = @_;
+
+ if(adminserv::is_svsop($user, adminserv::S_HELP()) or adminserv::is_service($user)) {
+ return 0;
+ }
+ my $flev = flood_inc($user, $amount);
+
+ if($flev > 8) {
+ kill_user($user, "Flooding services.");
+ return 1;
+ }
+ elsif($flev > 6) {
+ notice($user, "You are flooding services.") if $amount == 1;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+sub get_user_id($) {
+ my ($user) = @_;
+ my ($id, $n);
+
+ return undef if(is_agent($user->{NICK}) and not $enforcers{lc $user->{NICK}});
+
+ unless(ref($user) eq 'HASH') {
+ die("invalid get_user_nick call");
+ }
+
+ if(exists($user->{ID})) { return $user->{ID}; }
+
+ my $nick = $user->{NICK};
+
+ # a cheat for isServer()
+ if($user->{NICK} =~ /\./) {
+ return $user->{ID} = undef;
+ }
+
+ if($nick eq '') {
+ die("get_user_id called on empty string");
+ }
+
+ my $nick2;
+ while($n < 10 and !defined($id)) {
+ $n++;
+ $get_user_id->execute($nick);
+ ($id) = $get_user_id->fetchrow_array;
+ unless($id) {
+ $get_nickchg->execute($nick);
+ ($id, $nick2) = $get_nickchg->fetchrow_array;
+ }
+ }
+
+ #unless($id) { log::wlog(__PACKAGE__, log::DEBUG(), "get_user_id($nick) failed."); }
+
+ if(defined($nick2) and lc $nick2 ne lc $user->{NICK}) {
+ $user->{OLDNICK} = $user->{NICK};
+ $user->{NICK} = $nick2;
+ }
+
+ return $user->{ID} = $id;
+}
+
+sub get_user_nick($) {
+ my ($user) = @_;
+
+ unless(ref($user) eq 'HASH') {
+ die("invalid get_user_nick call");
+ }
+
+ if(exists($user->{NICK}) and is_online($user->{NICK})) { return $user->{NICK} }
+
+ # Possible bug? This next bit only works to chase the nick-change
+ # if the caller already did a get_user_id to find out
+ # if the user exists in the user table, and thus get $user->{ID}
+ # I don't know if calling get_user_id here is safe or not.
+ my $nick;
+ if($user->{ID}) {
+ $get_user_nick->execute($user->{ID});
+ ($nick) = $get_user_nick->fetchrow_array;
+ }
+
+ # avoid returning an undef/NULL here. That's only legal for get_user_id
+ # If the user does not exist, we must avoid modifying the input
+ # so that it may be used for the error paths.
+ return (defined $nick ? $user->{NICK} = $nick : $user->{NICK});
+}
+
+sub get_user_agent($) {
+ my ($user) = @_;
+
+=cut
+ eval { $user->{AGENT} };
+ if($@) {
+ die("invalid get_user_agent call");
+ }
+=cut
+ die "invalid get_user_agent call" unless ref($user) eq 'HASH';
+
+ if(exists($user->{AGENT})) {
+ return $user->{AGENT}
+ }
+ else {
+ return undef;
+ }
+}
+
+sub is_online($) {
+ my ($user) = @_;
+ my $nick;
+
+ if(ref($user)) {
+ if(exists($user->{ONLINE})) { return $user->{ONLINE}; }
+ $nick = get_user_nick($user);
+ } else {
+ $nick = $user;
+ }
+
+ $is_online->execute($nick);
+ my ($status) = $is_online->fetchrow_array;
+ $is_online->finish();
+ if(ref($user)) {
+ $user->{ONLINE} = ($status ? 1 : 0);
+ }
+
+ return $status;
+}
+
+sub chk_online($$) {
+ my ($user, $target) = @_;
+
+ unless(is_online($target)) {
+ if(ref($target)) {
+ $target = get_user_nick($target);
+ }
+
+ notice($user, "\002$target\002: No such user.");
+ return 0;
+ }
+
+ return 1;
+}
+
+sub set_user_flag($$;$) {
+ my ($user, $flag, $sign) = @_;
+ my $uid = get_user_id($user);
+ $sign = 1 unless defined($sign);
+
+ if($sign) {
+ $user->{FLAGS} = ( ( defined $user->{FLAGS} ? $user->{FLAGS} : 0 ) | $flag );
+ $set_user_flag->execute($flag, $uid);
+ } else {
+ $user->{FLAGS} = ( ( defined $user->{FLAGS} ? $user->{FLAGS} : 0 ) & ~($flag) );
+ $unset_user_flag->execute($flag, $uid);
+ }
+}
+
+sub chk_user_flag($$;$) {
+ my ($user, $flag, $sign) = @_;
+ my $flags = get_user_flags($user);
+ $sign = 1 unless defined($sign);
+
+ return ($sign ? ($flags & $flag) : !($flags & $flag));
+}
+
+sub get_user_flags($) {
+ my ($user) = @_;
+ my $uid = get_user_id($user);
+
+ my $flags;
+ unless (exists($user->{FLAGS})) {
+ $get_user_flags->execute($uid);
+ ($flags) = $get_user_flags->fetchrow_array;
+ $get_user_flags->finish();
+ } else {
+ $flags = $user->{FLAGS};
+ }
+
+ return $user->{FLAGS} = $flags;
+}
+
+sub set_user_flag_all($) {
+ my ($flags) = @_;
+
+ $set_user_flag_all->execute($flags);
+ $set_user_flag_all->finish();
+}
+
+sub get_host($) {
+ my ($user) = @_;
+
+ my $id;
+ if(ref($user)) {
+ $id = get_user_id($user);
+ } else {
+ $id = get_user_id({ NICK => $user });
+ }
+ return undef unless $id;
+
+ $get_host->execute($id);
+ my ($ident, $host) = $get_host->fetchrow_array;
+
+ return ($ident, $host);
+}
+
+sub get_cloakhost($) {
+ my ($user) = @_;
+
+ my $id;
+ if(ref($user)) {
+ $id = get_user_id($user);
+ } else {
+ $id = get_user_id({ NICK => $user });
+ }
+ return undef unless $id;
+
+ $get_cloakhost->execute($id);
+ my ($valid, $cloakhost) = $get_cloakhost->fetchrow_array;
+ $get_cloakhost->finish;
+
+ # Beware, $cloakhost may be NULL while the user entry exists
+ # if $cloakhost == undef, check $valid before assuming no such user.
+ return ($valid, $cloakhost);
+}
+
+sub get_vhost($) {
+ my ($user) = @_;
+
+ my $id;
+ if(ref($user)) {
+ $id = get_user_id($user);
+ } else {
+ $id = get_user_id({ NICK => $user });
+ }
+ return undef unless $id;
+
+ $get_vhost->execute($id);
+ my ($ident, $vhost) = $get_vhost->fetchrow_array;
+
+ return ($ident, $vhost);
+}
+
+sub get_user_info($) {
+ my ($user) = @_;
+
+ my $uid = get_user_id($user);
+ return undef() unless $uid;
+
+ return __get_user_info($uid);
+}
+
+=cut
+sub get_user_ipv4($) {
+ my ($user) = @_;
+
+ my $id;
+ if(ref($user)) {
+ if(exists $user->{IP}) {
+ return $user->{IP};
+ }
+ $id = get_user_id($user);
+ } else {
+ $id = get_user_id({ NICK => $user });
+ }
+ return undef unless $id;
+
+ my $ip = getIPV4($id);
+ if(ref($user)) {
+ return $user->{IP} = $ip;
+ } else {
+ return $ip;
+ }
+}
+=cut
+
+sub get_user_ip($) {
+ my ($user) = @_;
+
+ my $id;
+ if (ref($user)) {
+ if(exists $user->{IP}) {
+ return $user->{IP};
+ }
+ $id = get_user_id($user);
+ } else {
+ $id = get_user_id({ NICK => $user});
+ }
+ return undef unless $id;
+
+ my ($ipv4,$ipv6) = __getIP($id);
+ if (defined $ipv6) {
+ return $user->{IP} = $ipv6 unless !ref($user);
+ return $ipv6;
+ } else {
+ return $user->{IP} = $ipv4 unless !ref($user);
+ return $ipv4;
+ }
+}
+
+sub kill_user($$) {
+ my ($user, $reason) = @_;
+
+ ircd::irckill(get_user_agent($user) || main_conf_local, get_user_nick($user), $reason);
+}
+
+sub kline_user($$$) {
+ my ($user, $time, $reason) = @_;
+ my $agent = get_user_agent($user);
+ my ($ident, $host) = get_host($user);
+
+ ircd::kline($agent, '*', $host, $time, $reason);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::User::Notice;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw(notice user_die) }
+
+use SrSv::User qw(get_user_nick);
+
+sub notice($@) {
+ my $user = shift;
+
+ # FIXME: ref to 'NickServ' should call for the agent-nick in nickserv.pm,
+ # but that's not available at this layer, so we'd be making
+ # a blind reference to something that _might_ be undef
+ ircd::notice($user->{AGENT} || 'NickServ', get_user_nick($user), @_);
+}
+
+sub user_die($@) {
+ ¬ice;
+
+ die 'user';
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::User::Notice;
+
+use strict;
+
+use Exporter 'import';
+BEGIN { our @EXPORT = qw(add_user_tag get_user_tags check_user_tags) }
+
+use SrSv::User qw(get_user_nick get_user_id);
+
+use SrSv::MySQL::Stub (
+ __add_user_tag => ['INSERT', "INSERT IGNORE INTO usertags (userid, tag) VALUES (?,?)"],
+ __get_user_tags => ['COLUMN', 'SELECT tag FROM usertags WHERE userid=?'],
+ __check_user_tags => ['SCALAR', 'SELECT 1 FROM usertags WHERE userid=? AND tag=?'],
+);
+
+sub add_user_tag($$) {
+ my ($user, $tag) = @_;
+ return __add_user_tag(get_user_id($user), $tag);
+}
+sub get_user_tags($$) {
+ my ($user, $tag) = @_;
+ return __get_user_tags(get_user_id($user));
+}
+sub check_user_tags($$) {
+ my ($user, $tag) = @_;
+ return __check_user_tag(get_user_id($user), $tag);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+package SrSv::Util;
+
+use strict;
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT = qw(min max makeSeqList seqifyList);
+ our @EXPORT_OK = qw(
+ say say2 say3 sayFH sayERR
+ slurpFile dumpFile
+ interpretSuffixes humanizeBigNums
+ unique countUnique
+ );
+ our %EXPORT_TAGS = (
+ say => [qw( say say2 say3 sayFH sayERR )],
+ );
+
+}
+
+sub min($$) {
+ return ($_[0] < $_[1] ? $_[0] : $_[1]);
+}
+sub max($$) {
+ return ($_[0] > $_[1] ? $_[0] : $_[1]);
+}
+
+# This one only exists b/c it should be faster/simpler
+# than the unique() below
+sub __uniq(@) {
+ return keys %{{ map { $_ => 1 } @_ }}
+}
+# the sort is modified to sort numerically rather than by string.
+sub __numSort(@) {
+ return sort( {$a <=> $b} @_ );
+}
+
+sub makeSeqList(@) {
+ my @nums;
+ foreach my $arg (@_) {
+ foreach my $parm (split(',', $arg)) {
+ if ($parm =~ /^(\d+)(?:-|\.\.)(\d+)$/) {
+ push @nums, min($1, $2)..max($1, $2);
+ } elsif(misc::isint($parm)) {
+ push @nums, $parm;
+ } else {
+ # just ignore it. we could try throwing an error.
+ }
+ }
+ }
+ # map is a uniqify in case of duplicates
+ return __numSort( __uniq(@nums) );
+}
+
+sub __seqify($$) {
+ my ($lowNum, $highNum) = @_;
+ if($lowNum == $highNum) {
+ return $lowNum;
+ } else {
+ return "${lowNum}..${highNum}";
+ }
+}
+sub seqifyList(@) {
+ my @nums = __numSort( __uniq(@_) );
+ my $lowNum = shift @nums;
+ my $highNum = $lowNum;
+ my @seqs;
+ foreach my $num (@nums) {
+ if($num == ($highNum + 1)) {
+ # one could also $highNum++
+ # which would on a register-based CPU/VM be potentially faster
+ # and only use one register, assuming it implemented it via inc(reg)
+ # otoh, $num is already loaded into a reg, right?
+ $highNum = $num;
+ } else {
+ push @seqs, __seqify($lowNum, $highNum);
+ $lowNum = $highNum = $num;
+ }
+ }
+ push @seqs, __seqify($lowNum, $highNum);
+ return @seqs;
+}
+
+sub __say($@) {
+ my ($chr, @list) = @_;
+ return join( '', map( {"$_$chr"} @list) );
+}
+sub _say(@) {
+ return __say ("\n", @_);
+}
+sub say(@) {
+ print _say(@_);
+}
+sub sayFH($@) {
+ my ($fh, @list) = @_;
+ print $fh _say(@list);
+}
+sub sayERR(@) {
+ sayFH(*STDERR, @_);
+}
+sub say2(@) {
+ say( __say( ' ', @_) );
+}
+sub say3(@) {
+ say( __say( ',', map({"\"$_\"" } @_) ) );
+}
+
+sub slurpFile($) {
+ my ($filename) = @_;
+ open((my $fh), '<', $filename) or return;
+ binmode $fh;
+ local $/;
+ my $data = <$fh>;
+ close $fh;
+ return $data;
+}
+
+sub dumpFile($@) {
+ my ($filename, @data) = @_;
+ open((my $fh), '>', $filename);
+ binmode $fh;
+ print $fh join("\n", map({ chomp $_; $_ } @data));
+ close $fh;
+}
+
+my %suffixes = ( 'k' => 1024, 'm' => 1048576, 'g' => 1024**3, 't' => 1024**4 );
+sub interpretSuffixes($) {
+ my ($mem) = @_;
+ $mem =~ /^(\d+)\s*([kmgt])?(?:i?B)?$/i;
+ my ($num, $suffix) = ($1, $2);
+ if($suffix) {
+ return $num * $suffixes{lc $suffix};
+ } else {
+ return $num;
+ }
+}
+
+sub humanizeBigNums($;$) {
+ my ($val, $precision) = @_;
+ $precision = 2 unless $precision;
+ #return $val;
+ #return sprintf("%.2gMiB", $val / (1 << 20));
+ if($val > (1 << 40)) {
+ return sprintf("%.${precision}fTiB", $val / (1 << 40));
+ }
+ elsif($val > (1 << 30)) {
+ return sprintf("%.${precision}fGiB", $val / (1 << 30));
+ }
+ elsif($val > (1 << 20)) {
+ return sprintf("%.${precision}fMiB", $val / (1 << 20));
+ }
+ elsif($val > (1 << 10)) {
+ return sprintf("%.${precision}fKiB", $val / (1 << 10));
+ }
+}
+
+sub __unique($) {
+ my ($input_arrayRef) = @_;
+ my %seen; keys(%seen) = scalar(@$input_arrayRef) / 2;
+ no warnings 'uninitialized';
+ foreach my $item (@$input_arrayRef) {
+ $seen{$item}++;
+ }
+ return %seen;
+}
+sub unique(@) {
+ my (@input_array) = @_;
+ my %seen = __unique(\@input_array);
+ return sort(keys(%seen));
+}
+sub countUnique(@) {
+ my (@input_array) = @_;
+ my %seen = __unique(\@input_array);
+ return map("$_($seen{$_})", sort(keys(%seen)));
+}
+
+
+1;
--- /dev/null
+-----------------------------------------------------------------------
+VERSION-SPECIFIC CHANGES
+
+0.4.1:
+You must move all mysql settings from services.conf to sql.conf
+
+0.4.2: Adds support for password-hashing, and makes a lot of changes to
+the database schema. running db-setup.pl is required.
+
+0.4.3: Changes the SQL schema upgrading method to be safer and simpler.
+Changes the schema quite a bit even so. You MUST run the upgrade of
+0.4.2 before you can run the upgrade on 0.4.3. After 0.4.3 you should be
+able to skip versions if desired.
+
+-----------------------------------------------------------------------
+
+The db-setup.pl script should perform any database changes or
+conversions.
+
+If you have any problems, contact the coders on SurrealChat.net in
+#dev.lounge. We'll help out as best we can.
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => dirname(abs_path($0)),
+ );
+ require constant; import constant(\%constants);
+ chdir $constants{PREFIX};
+}
+use lib PREFIX, "@{[PREFIX]}/CPAN";
+
+use SrSv::Conf 'sql';
+
+$dbh = DBI->connect('DBI:mysql:'.$sql_conf{'mysql-db'}, $sql_conf{'mysql-user'}, $sql_conf{'mysql-pass'},
+ { AutoCommit => 1, RaiseError => 1 });
+
+$get_root_nick = $dbh->prepare("SELECT nickreg.nick FROM nickalias,nickreg WHERE nickalias.nrid=nickreg.id AND alias=?");
+$create_svsop = $dbh->prepare("INSERT IGNORE INTO svsop SELECT nickreg.id, 0, '' FROM nickreg WHERE nickreg.nick=?");
+$set_svs_level = $dbh->prepare("UPDATE svsop, nickreg SET svsop.level=4, svsop.adder=''
+ WHERE svsop.nrid=nickreg.id AND nickreg.nick=?");
+
+$get_root_nick->execute($ARGV[0]);
+my ($root) = $get_root_nick->fetchrow_array;
+$get_root_nick->finish;
+
+unless($root) {
+ print "That nick does not exist.\n";
+ exit;
+}
+
+$create_svsop->execute($root);
+$create_svsop->finish;
+
+$set_svs_level->execute($root);
+$set_svs_level->finish;
+
+print "$root has been added as a Services Root.\n";
--- /dev/null
+ This is a utility for converting Anope databases to SrSv. For
+this to work, you'll need a current copy of ircservices for their
+convert-epona tool. This tool converts an epona/anope database to XML,
+and the parsexml script loads that XML file into your database.
+
+A) It does not handle channel access, as there is no reliable conversion
+between anope's LEVELS system and SrSv's xOP system.
+
+B) It currently does not handle memos, although it probably could.
+
+C) As SrSv has no concept of forbidden nicks or channels (nicks are
+usually handled by just registering, and holding, and channels can be
+just closed) this is not handled either.
+
+D) Channel passwords are simply discarded, as SrSv does not use channel
+passwords.
+
+E) This program has not been tested with a recent anope database,
+although we believe it was done with an early 1.7.x version.
+
+F) It is likely that the conversion can be done w/o the ircservices
+tools by converting Anope's MySQL database directly, however it has not
+been done yet.
+
+G) This database converter is BETA SOFTWARE. It is not guaranteed to not
+eat your data for lunch with a little barbecue sauce, and then burp
+happily.
+
+H) At present, merging two databases is NOT SUPPORTED, although it
+should be entirely possible. It merely has not been tested. Further,
+there is NO resolution method for collisions between the two databases
+for either channels or nicks.
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use XML::Twig;
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+chdir PREFIX;
+use lib PREFIX;
+
+use SrSv::Conf 'sql';
+
+my $db = 1;
+
+my ($dbh);
+my (
+ $is_chan_reg, $regchan, $add_topic, $create_acc,
+
+ $is_nick_reg, $regnick, $create_alias
+);
+my ($time);
+
+if($db) {
+ eval {
+ $dbh = DBI->connect("DBI:mysql:".$sql_conf{'mysql-db'}, $sql_conf{'mysql-user'}, $sql_conf{'mysql-pass'},
+ { AutoCommit => 1, RaiseError => 1 });
+ };
+ if($@) {
+ print "FATAL: Can't connect to database:\n$@\n";
+ print "You must edit config/sql.conf and create a corresponding\nMySQL user and database!\n\n";
+ exit;
+ }
+
+ $is_chan_reg = $dbh->prepare("SELECT 1 FROM chanreg WHERE chan=?");
+ $regchan = $dbh->prepare("INSERT IGNORE INTO chanreg (chan, descrip, founderid, regd, last, topicer, topicd)
+ SELECT ?, ?, nickreg.id, ?, ?, ?, ? FROM nickalias
+ JOIN nickreg ON (nickalias.nrid=nickreg.id)
+ WHERE nickalias.alias=?");
+
+ $add_topic = $dbh->prepare("INSERT INTO chantext SET chan=?, type=1, data=?");
+ $create_acc = $dbh->prepare("INSERT INTO chanacc (chan,nrid,level)
+ SELECT ?, nickreg.id, ? FROM nickalias
+ JOIN nickreg ON (nickreg.id=nickalias.nrid)
+ WHERE alias=?");
+
+ $is_nick_reg = $dbh->prepare("SELECT 1 FROM nickalias WHERE alias=?");
+ $regnick = $dbh->prepare("INSERT INTO nickreg
+ SET nick=?, pass=?, email=?, regd=?, last=?, flags=1, ident='unknown', vhost='unknown', gecos=''");
+ $create_alias = $dbh->prepare("INSERT INTO nickalias (nrid, alias, protect, last)
+ SELECT id, ?, 1, 0 FROM nickreg WHERE nick=?");
+
+ $time = time();
+}
+
+my %nickids;
+my %ignorenicks;
+
+open ((my $FBN), '>', "nicks.forbid");
+open ((my $FBC), '>', "chans.forbid");
+
+my $crap;
+{
+ local $/;
+ $crap = <>;
+}
+
+$crap =~ s/\%/%%/g;
+$crap =~ s/&#/%/g;
+
+my $twig=XML::Twig->new(
+ twig_handlers =>
+ { nickgroupinfo => \&insert_nick,
+ channelinfo => \&insert_chan
+ },
+ keep_encoding => 1
+);
+$twig->parse($crap);
+$twig->purge;
+
+sub insert_nick {
+ my ($t, $section) = @_;
+
+ my $id = $section->first_child_text('id');
+ print "ID: $id\n";
+
+ my $root;
+ my $nickst = $section->first_child('nicks');
+ my @nickts = $nickst->children('array-element');
+ my @aliases;
+ foreach my $nt (@nickts) {
+ my $nick = $nt->text;
+ print "Alias: $nick\n";
+
+ if($db) {
+ $is_nick_reg->execute($nick);
+ if($is_nick_reg->fetchrow_array) {
+ print "Already registered!\n\n";
+ $ignorenicks{$id} = 1;
+ return;
+ }
+ }
+
+ push @aliases, $nick;
+ }
+ my $root = @aliases[0];
+
+ $nickids{$id} = $root;
+
+ my $pass = $section->first_child_text('pass');
+
+ if($pass eq '') {
+ print "Forbidden!\n\n";
+ print $FBN "$root\n";
+ return;
+ }
+
+ print "Pass: $pass\n";
+
+ my $email = $section->first_child_text('email');
+ print "Email: $email\n";
+
+ if($db) {
+ $regnick->execute($root, $pass, $email, $time, $time);
+
+ foreach my $alias (@aliases) {
+ $create_alias->execute($alias, $root);
+ }
+ }
+
+ print "\n";
+
+ $t->purge;
+}
+
+sub insert_chan {
+ my ($t, $section) = @_;
+
+ my $chan = $section->first_child_text('name');
+ print "Chan: $chan\n";
+
+ if($db) {
+ $is_chan_reg->execute($chan);
+ if($is_chan_reg->fetchrow_array) {
+ print "Already registered!\n\n";
+ return;
+ }
+ }
+
+ my $founderid = $section->first_child_text('founder');
+
+ if($founderid == 0) {
+ print "Forbidden!\n\n";
+ print $FBC "$chan\n";
+ return;
+ }
+
+ if($ignorenicks{$founderid}) {
+ print "Founder nick was already registered!\n\n";
+ return;
+ }
+
+ my $founder = $nickids{$founderid};
+ print "Founder: $founder\n";
+ die("No founder!") unless $founder;
+
+ my $topic = $section->first_child_text('last_topic');
+ $topic =~ s/%(\d+);/chr($1)/eg;
+ $topic =~ s/%%/%/g;
+ my $topictime = $section->first_child_text('last_topic_time');
+ my $topicset = $section->first_child_text('last_topic_setter');
+ my $desc = $section->first_child_text('desc');
+ my $pass = $section->first_child_text('founderpass');
+ my $last = $section->first_child_text('last_used');
+ my $regd = $section->first_child_text('time_registered');
+
+ if($db) {
+ $regchan->execute($chan, $desc, $regd, $last, $topicset, $topictime, $founder);
+ $add_topic->execute($chan, $topic);
+ $create_acc->execute($chan, 7, $founder);
+ }
+
+ print "\n";
+
+ $t->purge;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use DBI;
+
+%acc = (
+ 3 => 2,
+ 4 => 3,
+ 5 => 4,
+ 10 => 5,
+ 13 => 6
+);
+
+$dbh = DBI->connect("DBI:mysql:services", "services", "yQ0AaCLdMhfEBTpxwc0OWw", { AutoCommit => 1, RaiseError => 1 });
+
+$register = $dbh->prepare("INSERT IGNORE INTO chanreg SET chan=?, descrip=?, founder=?, pass=?, regd=?, last=?, topic=?, topicer='unknown', topicd=?, successor=?, bot=?");
+$create_acc = $dbh->prepare("INSERT IGNORE INTO chanacc SET chan=?, nick=?, level=?, adder=?");
+
+$time = time();
+
+open FILE, $ARGV[0];
+
+# 0name;1founder;2pass;3time_registered;4url;email;5mlock_key;6welcome;7hold;8mark;9freeze;10forbid;11successor;12mlock_link;13mlock_flood;14bot;15markreason;16freezereason;17holdreason;18lastgetpass;19access-level:nick:adder;20last_topic\ndesc
+
+while(@in = split(/;/, <FILE>)) {
+ die("Too many fields in $in[0]") if @in > 21;
+ $topic = <FILE>; chomp $topic;
+ $desc = <FILE>; chomp $desc;
+ @data = ($in[0], $desc, $in[1], $in[2], $in[3], $time, $topic, $time, $in[12], $in[15]);
+ print join(', ', @data), "\n";
+ $register->execute(@data);
+ $create_acc->execute($in[0], $in[1], 7, '');
+
+ foreach $acc (split(/,/, $in[20])) {
+ @d = split(/:/, $acc);
+ next unless @d == 3;
+ $d[0] = $acc{$d[0]};
+
+ print "acc: ", join(', ', @d), "\n";
+ $create_acc->execute($in[0], $d[1], $d[0], $d[2]);
+ }
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use DBI;
+
+$dbh = DBI->connect("DBI:mysql:services", "services", "yQ0AaCLdMhfEBTpxwc0OWw", { AutoCommit => 1, RaiseError => 1 });
+
+$register = $dbh->prepare("INSERT IGNORE INTO nickreg SET nick=?, pass=?, email=?, regd=?, last=?, flags=1, ident=?, vhost=?, gecos=?, quit=?");
+$create_alias = $dbh->prepare("INSERT IGNORE INTO nickalias SET root=?, alias=?");
+
+$time = time();
+
+open FILE, $ARGV[0];
+
+while(@in = split(/;/, <FILE>)) {
+ next unless($in[2] eq 'slave:no');
+
+ my ($ident, $host) = split('@', $in[3]) or ('', '');
+ next unless $ident;
+
+ @data = ($in[0], $in[1], $in[6], $in[4], $time, $ident, $host, $in[17], $in[16]);
+ print join(', ', @data), "\n";
+ $register->execute(@data);
+ $create_alias->execute($in[0], $in[0]);
+}
+
+open FILE, $ARGV[0];
+
+while(@in = split(/;/, <FILE>)) {
+ next unless($in[2] eq 'slave:yes');
+
+ @data = ($in[3], $in[0]);
+ print join(', ', @data), "\n";
+ $create_alias->execute(@data);
+}
--- /dev/null
+# whether ConnectServ should list JOIN/PART events
+joinpart = 0
--- /dev/null
+# This is the servername for services (it shows up in /map and /list).
+# It MUST contain at least one dot per RFC1459.
+local = services.example.com
+
+# This is the name or IP of the IRC-server/Hub that services
+# will connect to.
+remote = hub.example.com
+
+# This is the port to connect to. This port must accept server
+# connections (cannot be 'clientonly'). Nor can it be an SSL
+# port. SrSv does not support ziplinks either.
+port = 6667
+
+# This is UnrealIRCd's server numeric. You must set this to
+# a unique value.
+numeric = 123
+
+# This is for enabling IPv6 usage. You must set this to
+# 1 for true, or 0 for false.
+# IPv6 support isn't known to be bug-free, but it is running on SCnet.
+# If you see errors about 'Socket6' you have to disable this.
+ipv6 = 0
+
+# You can set this to anything you want, it shows up in
+# /whois and /links
+info = SurrealServices
+
+# Server link password. Must match the appropriate link{} block
+# in the ircd config.
+pass = mypass
+
+# Number of worker processes. Note that increasing this above 4
+# will most likely only slow things down -- see README file.
+procs = 4
+
+# Diagnostic channel where you can monitor what services is doing.
+diag = #Diagnostics
+
+# List of modules to load. See README.
+load = core, services
+
+# The name of your network.
+# Not really used for anything anymore, we just take 005's NETWORK
+netname = ExampleNet
+
+# The email address that services will use for nearexpire,
+# sendpass, etc.
+email = Example IRC Services <services@example.com>
+
+# This is the Reply-To: field. This should be set to an address
+# of your network staff. Or set it to "noreply" if you hate
+# your users.
+replyto = staff@example.com
+
+# This line will be at the end of each email sent by services.
+sig = Thank you for chatting with us.
+
+# If you use NeoStats, set this to the name of your NeoStats
+# server. Otherwise, leave it commented out.
+#unsyncserver = [neostats.example.com, denora.example.com]
+
+# Uncomment this if you don't want any emails to be sent.
+#nomail = 1
+
+# This is the address for maillogs.
+#logmail = staff@example.com
+
+# This determines whether passwords in services (and possibly some other modules)
+# are hashed or stored plain-text. hashing passwords mostly makes password-theft
+# harder, if the database is accessed by someone who should not have it.
+# default is off, but recommended to be turned on:
+# a) if your network is under threat of hacking
+# b) if your network is large
+# c) to alleviate some fears from users.
+#
+# If you set this to 1, and run db-setup, all of the nickreg passes will be
+# hashed for you. This process is irreversible, short of reverting to
+# a backup copy of your database. Keeping the backup for any period of time
+# violates the point of hashing your passwords.
+hashed-passwords = 0
+
+# Used for the special channel bantype 10
+
+# The assumption is that anything that starts with one of these prefixes
+# and a hyphen has a per-user ident that is maintained by a cookie and
+# should be reasonably persistent.
+#ban_webchat_prefixes = java|htIRC
+
+# Using tokens uses less bandwidth for processing commands
+# The TOK_FOO are shorter than CMD_FOO and can also allow faster hash matching
+# for command dispatch.
+# DON'T CHANGE UNLESS YOU'RE A DEVELOPER
+tokens = 1
+
+# If the queue size goes over this,
+# a) low priority user commands are ignored and user is asked to come back later.
+# b) services notifies opers that this has occurred
+# c) svsop are exempt.
+highqueue = 20
+
+operchan = #opers
--- /dev/null
+FloodGraceBackoff = 1
+DroneKlineReason = Botnet/Drone Channel
+FloodKlineTime = 3600
+MaxCloneTime = 0
+CloneKlineReason = Too Many Connections or Connecting Too Fast (Automatic Temporary K:Line)
+DroneKlineTime = 21600
+Debug = 0
+FloodGraceTime = 120
+MaxClones = 1024
+EnableConnTrack = 1
+CloneKillReason = Cloning Detected
+CloneKlineTime = 120
+Debugger = #diagnostics
+EnableFloodTrack = 1
+FloodKlineReason = Repeated Flooding (Automatic Ban)
+AuthWarnFail = 1
+EnableAutoFP = 0
+FloodGrace = 100
+CTCPonConnect = VERSION LAG
+ss_Username = username
+ss_Pass = pass
+ss_SkipFilters = DCCSEND IRCSpam HTTPSpam HTTPSpamChan
+EnableOPM = 0
+OPMZlineReason = Open proxy - see http://opm.blitzed.org/$
+ProxyZlineTime = 21600
+TorZlineReason = You are not permitted to connect to this network using anonymous proxies.
+TorServer = http://tor.noreply.org/tor/status/all
+EnableTor = 1
+CountryZlineReason = Due to persistent abuse, access to this network from $ is denied.
--- /dev/null
+# If this is set to 1, channels and nicknames will not expire.
+# This is useful after a long-term downtime where you want to
+# give a chance for people to come back and renew their nicks.
+noexpire = 0
+
+# The number of days a nick lasts before expiring.
+nickexpire = 21
+
+# The number of days a nick can be in vacation mode.
+vacationexpire = 90
+
+# Number of days before expiration where services will send
+# a reminder to the owner of the nick. Set to 0 to turn
+# this feature off.
+nearexpire = 7
+
+# Number of days a channel lasts before expiring.
+chanexpire = 21
+
+# If this is set to 1, users must validate their email
+# address in order to register a nick.
+validate-email = 0
+
+# Number of days a non-validated nick will last.
+validate-expire = 1
+
+# Maximum connections from the same IP.
+clone-limit = 3
+
+# Automatic gline time in seconds
+chankilltime = 86400
+
+# Default protection level for new nicknames.
+default-protect = normal
+
+#Whether to log override use. Not all overrides are logged yet!
+log-overrides = 0
+
+# Default channel bot for all registrations
+#default-chanbot = ChanBot
+
+# default mlock for channels when registered
+#default_channel_mlock = +nrt
+
+# Restricts channel registration to network staff
+# (anyone with helpop or higher)
+#chanreg-needs-oper = 0
+
+# Allows you to add secondary names for the agents
+botserv = undef
+nickserv = undef
+chanserv = undef
+memoserv = undef
+adminserv = undef
+operserv = undef
+hostserv = undef
+
+#Example:
+#botserv = Botty
+#nickserv = NomServ
+#chanserv = RoomService
+#memoserv = Question
+#adminserv = Secretary
+#operserv = Bouncer
+#hostserv = Butler
+
+# How long after signoff (or netsplit) a user entry is deleted/expired from.
+# the table in case they come back with the same userid & timestamp.
+# It also determines how long OS UINFO will be able to retrieve information
+# about a user assuming that no one has used that nick since.
+# The value is in seconds. Default is 300 (5 minutes)
+#old_user_age = 300
--- /dev/null
+pikachu
+charmander
+jynx
+blastoise
+typhlosion
+squirtle
+Raichu
+giratinaorigin
--- /dev/null
+# This sets the maximum amount of time, in seconds,
+# for pseudoclients to idle in a given channel,
+# before cycling over to a new pseudoclient
+#
+# Default is 14400 seconds, or 4 hours
+#
+idlemax = 14400
+
+# Same as above, except this sets the minimum
+# amount of time a pseudoclient will be in
+# a channel.
+#
+# Default is 3600 seconds, or 1 hour
+#
+idlemin = 3600
--- /dev/null
+# The username, password, and database for MySQL.
+mysql-user = services
+mysql-pass = mypass
+mysql-db = services
+
+# This is an optimization for MySQL 4.x,
+# but breaks HORRIBLY on MySQL 5.0 and newer DBI/DBDs
+server_prepare = 0
--- /dev/null
+500 Portland-Auburn, ME
+501 New York, NY
+502 Binghamton, NY
+503 Macon, GA
+504 Philadelphia, PA
+505 Detroit, MI
+506 Boston, MA
+507 Savannah, GA
+508 Pittsburgh, PA
+509 Ft Wayne, IN
+510 Cleveland, OH
+511 Washington, DC
+512 Baltimore, MD
+513 Flint, MI
+514 Buffalo, NY
+515 Cincinnati, OH
+516 Erie, PA
+517 Charlotte, NC
+518 Greensboro, NC
+519 Charleston, SC
+520 Augusta, GA
+521 Providence, RI
+522 Columbus, GA
+523 Burlington, VT
+524 Atlanta, GA
+525 Albany, GA
+526 Utica-Rome, NY
+527 Indianapolis, IN
+528 Miami, FL
+529 Louisville, KY
+530 Tallahassee, FL
+531 Tri-Cities, TN
+532 Albany-Schenectady-Troy, NY
+533 Hartford, CT
+534 Orlando, FL
+535 Columbus, OH
+536 Youngstown-Warren, OH
+537 Bangor, ME
+538 Rochester, NY
+539 Tampa, FL
+540 Traverse City-Cadillac, MI
+541 Lexington, KY
+542 Dayton, OH
+543 Springfield-Holyoke, MA
+544 Norfolk-Portsmouth, VA
+545 Greenville-New Bern-Washington, NC
+546 Columbia, SC
+547 Toledo, OH
+548 West Palm Beach, FL
+549 Watertown, NY
+550 Wilmington, NC
+551 Lansing, MI
+552 Presque Isle, ME
+553 Marquette, MI
+554 Wheeling, WV
+555 Syracuse, NY
+556 Richmond-Petersburg, VA
+557 Knoxville, TN
+558 Lima, OH
+559 Bluefield-Beckley-Oak Hill, WV
+560 Raleigh-Durham, NC
+561 Jacksonville, FL
+563 Grand Rapids, MI
+564 Charleston-Huntington, WV
+565 Elmira, NY
+566 Harrisburg-Lancaster-Lebanon-York, PA
+567 Greenville-Spartenburg, SC
+569 Harrisonburg, VA
+570 Florence-Myrtle Beach, SC
+571 Ft Myers, FL
+573 Roanoke-Lynchburg, VA
+574 Johnstown-Altoona, PA
+575 Chattanooga, TN
+576 Salisbury, MD
+577 Wilkes Barre-Scranton, PA
+581 Terre Haute, IN
+582 Lafayette, IN
+583 Alpena, MI
+584 Charlottesville, VA
+588 South Bend, IN
+592 Gainesville, FL
+596 Zanesville, OH
+597 Parkersburg, WV
+598 Clarksburg-Weston, WV
+600 Corpus Christi, TX
+602 Chicago, IL
+603 Joplin-Pittsburg, MO
+604 Columbia-Jefferson City, MO
+605 Topeka, KS
+606 Dothan, AL
+609 St Louis, MO
+610 Rockford, IL
+611 Rochester-Mason City-Austin, MN
+612 Shreveport, LA
+613 Minneapolis-St Paul, MN
+616 Kansas City, MO
+617 Milwaukee, WI
+618 Houston, TX
+619 Springfield, MO
+620 Tuscaloosa, AL
+622 New Orleans, LA
+623 Dallas-Fort Worth, TX
+624 Sioux City, IA
+625 Waco-Temple-Bryan, TX
+626 Victoria, TX
+627 Wichita Falls, TX
+628 Monroe, LA
+630 Birmingham, AL
+631 Ottumwa-Kirksville, IA
+632 Paducah, KY
+633 Odessa-Midland, TX
+634 Amarillo, TX
+635 Austin, TX
+636 Harlingen, TX
+637 Cedar Rapids-Waterloo, IA
+638 St Joseph, MO
+639 Jackson, TN
+640 Memphis, TN
+641 San Antonio, TX
+642 Lafayette, LA
+643 Lake Charles, LA
+644 Alexandria, LA
+646 Anniston, AL
+647 Greenwood-Greenville, MS
+648 Champaign-Springfield-Decatur, IL
+649 Evansville, IN
+650 Oklahoma City, OK
+651 Lubbock, TX
+652 Omaha, NE
+656 Panama City, FL
+657 Sherman, TX
+658 Green Bay-Appleton, WI
+659 Nashville, TN
+661 San Angelo, TX
+662 Abilene-Sweetwater, TX
+669 Madison, WI
+670 Ft Smith-Fay-Springfield, AR
+671 Tulsa, OK
+673 Columbus-Tupelo-West Point, MS
+675 Peoria-Bloomington, IL
+676 Duluth, MN
+678 Wichita, KS
+679 Des Moines, IA
+682 Davenport-Rock Island-Moline, IL
+686 Mobile, AL
+687 Minot-Bismarck-Dickinson, ND
+691 Huntsville, AL
+692 Beaumont-Port Author, TX
+693 Little Rock-Pine Bluff, AR
+698 Montgomery, AL
+702 La Crosse-Eau Claire, WI
+705 Wausau-Rhinelander, WI
+709 Tyler-Longview, TX
+710 Hattiesburg-Laurel, MS
+711 Meridian, MS
+716 Baton Rouge, LA
+717 Quincy, IL
+718 Jackson, MS
+722 Lincoln-Hastings, NE
+724 Fargo-Valley City, ND
+725 Sioux Falls, SD
+734 Jonesboro, AR
+736 Bowling Green, KY
+737 Mankato, MN
+740 North Platte, NE
+743 Anchorage, AK
+744 Honolulu, HI
+745 Fairbanks, AK
+746 Biloxi-Gulfport, MS
+747 Juneau, AK
+749 Laredo, TX
+751 Denver, CO
+752 Colorado Springs, CO
+753 Phoenix, AZ
+754 Butte-Bozeman, MT
+755 Great Falls, MT
+756 Billings, MT
+757 Boise, ID
+758 Idaho Falls-Pocatello, ID
+759 Cheyenne, WY
+760 Twin Falls, ID
+762 Missoula, MT
+764 Rapid City, SD
+765 El Paso, TX
+766 Helena, MT
+767 Casper-Riverton, WY
+770 Salt Lake City, UT
+771 Yuma, AZ
+773 Grand Junction, CO
+789 Tucson, AZ
+790 Albuquerque, NM
+798 Glendive, MT
+800 Bakersfield, CA
+801 Eugene, OR
+802 Eureka, CA
+803 Los Angeles, CA
+804 Palm Springs, CA
+807 San Francisco, CA
+810 Yakima-Pasco, WA
+811 Reno, NV
+813 Medford-Klamath Falls, OR
+819 Seattle-Tacoma, WA
+820 Portland, OR
+821 Bend, OR
+825 San Diego, CA
+828 Monterey-Salinas, CA
+839 Las Vegas, NV
+855 Santa Barbara, CA
+862 Sacramento, CA
+866 Fresno, CA
+868 Chico-Redding, CA
+881 Spokane, WA
--- /dev/null
+- Unknown
+AD Andorra
+AE United Arab Emirates
+AF Afghanistan
+AG Antigua and Barbuda
+AI Anguilla
+AL Albania
+AM Armenia
+AN Netherlands Antilles
+AO Angola
+AQ Antarctica
+AR Argentina
+AS American Samoa
+AT Austria
+AU Australia
+AW Aruba
+AX Aland Islands
+AZ Azerbaijan
+BA Bosnia and Herzegovina
+BB Barbados
+BD Bangladesh
+BE Belgium
+BF Burkina Faso
+BG Bulgaria
+BH Bahrain
+BI Burundi
+BJ Benin
+BM Bermuda
+BN Brunei Darussalam
+BO Bolivia
+BR Brazil
+BS Bahamas
+BT Bhutan
+BV Bouvet Island
+BW Botswana
+BY Belarus
+BZ Belize
+CA Canada
+CC Cocos (Keeling) Islands
+CD Democratic Republic of the Congo
+CF Central African Republic
+CG Congo
+CH Switzerland
+CI Cote D'Ivoire (Ivory Coast)
+CK Cook Islands
+CL Chile
+CM Cameroon
+CN China
+CO Colombia
+CR Costa Rica
+CS Serbia and Montenegro
+CU Cuba
+CV Cape Verde
+CX Christmas Island
+CY Cyprus
+CZ Czech Republic
+DE Germany
+DJ Djibouti
+DK Denmark
+DM Dominica
+DO Dominican Republic
+DZ Algeria
+EC Ecuador
+EE Estonia
+EG Egypt
+EH Western Sahara
+ER Eritrea
+ES Spain
+ET Ethiopia
+FI Finland
+FJ Fiji
+FK Falkland Islands (Malvinas)
+FM Federated States of Micronesia
+FO Faroe Islands
+FR France
+FX France, Metropolitan
+GA Gabon
+GB Great Britain (UK)
+GD Grenada
+GE Georgia
+GF French Guiana
+GH Ghana
+GI Gibraltar
+GL Greenland
+GM Gambia
+GN Guinea
+GP Guadeloupe
+GQ Equatorial Guinea
+GR Greece
+GS S. Georgia and S. Sandwich Islands
+GT Guatemala
+GU Guam
+GW Guinea-Bissau
+GY Guyana
+HK Hong Kong
+HM Heard Island and McDonald Islands
+HN Honduras
+HR Croatia (Hrvatska)
+HT Haiti
+HU Hungary
+ID Indonesia
+IE Ireland
+IL Israel
+IN India
+IO British Indian Ocean Territory
+IQ Iraq
+IR Iran
+IS Iceland
+IT Italy
+JM Jamaica
+JO Jordan
+JP Japan
+KE Kenya
+KG Kyrgyzstan
+KH Cambodia
+KI Kiribati
+KM Comoros
+KN Saint Kitts and Nevis
+KP Korea (North)
+KR Korea (South)
+KW Kuwait
+KY Cayman Islands
+KZ Kazakhstan
+LA Laos
+LB Lebanon
+LC Saint Lucia
+LI Liechtenstein
+LK Sri Lanka
+LR Liberia
+LS Lesotho
+LT Lithuania
+LU Luxembourg
+LV Latvia
+LY Libya
+MA Morocco
+MC Monaco
+MD Moldova
+MG Madagascar
+MH Marshall Islands
+MK Macedonia
+ML Mali
+MM Myanmar
+MN Mongolia
+MO Macao
+MP Northern Mariana Islands
+MQ Martinique
+MR Mauritania
+MS Montserrat
+MT Malta
+MU Mauritius
+MV Maldives
+MW Malawi
+MX Mexico
+MY Malaysia
+MZ Mozambique
+NA Namibia
+NC New Caledonia
+NE Niger
+NF Norfolk Island
+NG Nigeria
+NI Nicaragua
+NL Netherlands
+NO Norway
+NP Nepal
+NR Nauru
+NU Niue
+NZ New Zealand (Aotearoa)
+OM Oman
+PA Panama
+PE Peru
+PF French Polynesia
+PG Papua New Guinea
+PH Philippines
+PK Pakistan
+PL Poland
+PM Saint Pierre and Miquelon
+PN Pitcairn
+PR Puerto Rico
+PS Palestinian Territory
+PT Portugal
+PW Palau
+PY Paraguay
+QA Qatar
+RE Reunion
+RO Romania
+RU Russian Federation
+RW Rwanda
+SA Saudi Arabia
+SB Solomon Islands
+SC Seychelles
+SD Sudan
+SE Sweden
+SG Singapore
+SH Saint Helena
+SI Slovenia
+SJ Svalbard and Jan Mayen
+SK Slovakia
+SL Sierra Leone
+SM San Marino
+SN Senegal
+SO Somalia
+SR Suriname
+ST Sao Tome and Principe
+SU USSR (former)
+SV El Salvador
+SY Syria
+SZ Swaziland
+TC Turks and Caicos Islands
+TD Chad
+TF French Southern Territories
+TG Togo
+TH Thailand
+TJ Tajikistan
+TK Tokelau
+TL Timor-Leste
+TM Turkmenistan
+TN Tunisia
+TO Tonga
+TP East Timor
+TR Turkey
+TT Trinidad and Tobago
+TV Tuvalu
+TW Taiwan
+TZ Tanzania
+UA Ukraine
+UG Uganda
+UK United Kingdom
+UM United States Minor Outlying Islands
+US United States
+UY Uruguay
+UZ Uzbekistan
+VA Vatican City State (Holy See)
+VC Saint Vincent and the Grenadines
+VE Venezuela
+VG Virgin Islands (British)
+VI Virgin Islands (U.S.)
+VN Viet Nam
+VU Vanuatu
+WF Wallis and Futuna
+WS Samoa
+YE Yemen
+YT Mayotte
+YU Yugoslavia (former)
+ZA South Africa
+ZM Zambia
+ZR Zaire (former)
+ZW Zimbabwe
+BIZ Business
+COM Commercial
+EDU US Educational
+GOV US Government
+INT International
+MIL US Military
+NET Network
+ORG Nonprofit Organization
+PRO Professional Services
+AERO Aeronautic
+ARPA Arpanet Technical Infrastructure
+COOP Cooperative
+INFO Info Domain
+NAME Personal Name
+NATO North Atlantic Treaty Organization
+MUSEUM Museum Domain Management Association (MuseDoma)
+XXX Pornography
+EU European Union
--- /dev/null
+"iso 3166 country","fips 10-4 region code","name"
+AD,02,"Canillo"
+AD,03,"Encamp"
+AD,04,"La Massana"
+AD,05,"Ordino"
+AD,06,"Sant Julia de Loria"
+AD,07,"Andorra la Vella"
+AD,08,"Escaldes-Engordany"
+AE,01,"Abu Dhabi"
+AE,02,"Ajman"
+AE,03,"Dubai"
+AE,04,"Fujairah"
+AE,05,"Ras Al Khaimah"
+AE,06,"Sharjah"
+AE,07,"Umm Al Quwain"
+AF,01,"Badakhshan"
+AF,02,"Badghis"
+AF,03,"Baghlan"
+AF,05,"Bamian"
+AF,06,"Farah"
+AF,07,"Faryab"
+AF,08,"Ghazni"
+AF,09,"Ghowr"
+AF,10,"Helmand"
+AF,11,"Herat"
+AF,13,"Kabol"
+AF,14,"Kapisa"
+AF,15,"Konar"
+AF,16,"Laghman"
+AF,17,"Lowgar"
+AF,18,"Nangarhar"
+AF,19,"Nimruz"
+AF,21,"Paktia"
+AF,22,"Parvan"
+AF,23,"Kandahar"
+AF,24,"Kondoz"
+AF,26,"Takhar"
+AF,27,"Vardak"
+AF,28,"Zabol"
+AF,29,"Paktika"
+AF,30,"Balkh"
+AF,31,"Jowzjan"
+AF,32,"Samangan"
+AF,33,"Sar-e Pol"
+AF,34,"Konar"
+AF,35,"Laghman"
+AF,36,"Paktia"
+AF,37,"Khowst"
+AF,38,"Nurestan"
+AF,39,"Oruzgan"
+AF,40,"Parvan"
+AF,41,"Daykondi"
+AF,42,"Panjshir"
+AG,01,"Barbuda"
+AG,03,"Saint George"
+AG,04,"Saint John"
+AG,05,"Saint Mary"
+AG,06,"Saint Paul"
+AG,07,"Saint Peter"
+AG,08,"Saint Philip"
+AL,40,"Berat"
+AL,41,"Diber"
+AL,42,"Durres"
+AL,43,"Elbasan"
+AL,44,"Fier"
+AL,45,"Gjirokaster"
+AL,46,"Korce"
+AL,47,"Kukes"
+AL,48,"Lezhe"
+AL,49,"Shkoder"
+AL,50,"Tirane"
+AL,51,"Vlore"
+AM,01,"Aragatsotn"
+AM,02,"Ararat"
+AM,03,"Armavir"
+AM,04,"Geghark'unik'"
+AM,05,"Kotayk'"
+AM,06,"Lorri"
+AM,07,"Shirak"
+AM,08,"Syunik'"
+AM,09,"Tavush"
+AM,10,"Vayots' Dzor"
+AM,11,"Yerevan"
+AO,01,"Benguela"
+AO,02,"Bie"
+AO,03,"Cabinda"
+AO,04,"Cuando Cubango"
+AO,05,"Cuanza Norte"
+AO,06,"Cuanza Sul"
+AO,07,"Cunene"
+AO,08,"Huambo"
+AO,09,"Huila"
+AO,10,"Luanda"
+AO,12,"Malanje"
+AO,14,"Moxico"
+AO,15,"Uige"
+AO,16,"Zaire"
+AO,17,"Lunda Norte"
+AO,18,"Lunda Sul"
+AO,19,"Bengo"
+AO,20,"Luanda"
+AR,01,"Buenos Aires"
+AR,02,"Catamarca"
+AR,03,"Chaco"
+AR,04,"Chubut"
+AR,05,"Cordoba"
+AR,06,"Corrientes"
+AR,07,"Distrito Federal"
+AR,08,"Entre Rios"
+AR,09,"Formosa"
+AR,10,"Jujuy"
+AR,11,"La Pampa"
+AR,12,"La Rioja"
+AR,13,"Mendoza"
+AR,14,"Misiones"
+AR,15,"Neuquen"
+AR,16,"Rio Negro"
+AR,17,"Salta"
+AR,18,"San Juan"
+AR,19,"San Luis"
+AR,20,"Santa Cruz"
+AR,21,"Santa Fe"
+AR,22,"Santiago del Estero"
+AR,23,"Tierra del Fuego"
+AR,24,"Tucuman"
+AT,01,"Burgenland"
+AT,02,"Karnten"
+AT,03,"Niederosterreich"
+AT,04,"Oberosterreich"
+AT,05,"Salzburg"
+AT,06,"Steiermark"
+AT,07,"Tirol"
+AT,08,"Vorarlberg"
+AT,09,"Wien"
+AU,01,"Australian Capital Territory"
+AU,02,"New South Wales"
+AU,03,"Northern Territory"
+AU,04,"Queensland"
+AU,05,"South Australia"
+AU,06,"Tasmania"
+AU,07,"Victoria"
+AU,08,"Western Australia"
+AZ,01,"Abseron"
+AZ,02,"Agcabadi"
+AZ,03,"Agdam"
+AZ,04,"Agdas"
+AZ,05,"Agstafa"
+AZ,06,"Agsu"
+AZ,07,"Ali Bayramli"
+AZ,08,"Astara"
+AZ,09,"Baki"
+AZ,10,"Balakan"
+AZ,11,"Barda"
+AZ,12,"Beylaqan"
+AZ,13,"Bilasuvar"
+AZ,14,"Cabrayil"
+AZ,15,"Calilabad"
+AZ,16,"Daskasan"
+AZ,17,"Davaci"
+AZ,18,"Fuzuli"
+AZ,19,"Gadabay"
+AZ,20,"Ganca"
+AZ,21,"Goranboy"
+AZ,22,"Goycay"
+AZ,23,"Haciqabul"
+AZ,24,"Imisli"
+AZ,25,"Ismayilli"
+AZ,26,"Kalbacar"
+AZ,27,"Kurdamir"
+AZ,28,"Lacin"
+AZ,29,"Lankaran"
+AZ,30,"Lankaran"
+AZ,31,"Lerik"
+AZ,32,"Masalli"
+AZ,33,"Mingacevir"
+AZ,34,"Naftalan"
+AZ,35,"Naxcivan"
+AZ,36,"Neftcala"
+AZ,37,"Oguz"
+AZ,38,"Qabala"
+AZ,39,"Qax"
+AZ,40,"Qazax"
+AZ,41,"Qobustan"
+AZ,42,"Quba"
+AZ,43,"Qubadli"
+AZ,44,"Qusar"
+AZ,45,"Saatli"
+AZ,46,"Sabirabad"
+AZ,47,"Saki"
+AZ,48,"Saki"
+AZ,49,"Salyan"
+AZ,50,"Samaxi"
+AZ,51,"Samkir"
+AZ,52,"Samux"
+AZ,53,"Siyazan"
+AZ,54,"Sumqayit"
+AZ,55,"Susa"
+AZ,56,"Susa"
+AZ,57,"Tartar"
+AZ,58,"Tovuz"
+AZ,59,"Ucar"
+AZ,60,"Xacmaz"
+AZ,61,"Xankandi"
+AZ,62,"Xanlar"
+AZ,63,"Xizi"
+AZ,64,"Xocali"
+AZ,65,"Xocavand"
+AZ,66,"Yardimli"
+AZ,67,"Yevlax"
+AZ,68,"Yevlax"
+AZ,69,"Zangilan"
+AZ,70,"Zaqatala"
+AZ,71,"Zardab"
+BA,01,"Federation of Bosnia and Herzegovina"
+BA,02,"Republika Srpska"
+BB,01,"Christ Church"
+BB,02,"Saint Andrew"
+BB,03,"Saint George"
+BB,04,"Saint James"
+BB,05,"Saint John"
+BB,06,"Saint Joseph"
+BB,07,"Saint Lucy"
+BB,08,"Saint Michael"
+BB,09,"Saint Peter"
+BB,10,"Saint Philip"
+BB,11,"Saint Thomas"
+BD,01,"Barisal"
+BD,04,"Bandarban"
+BD,05,"Comilla"
+BD,12,"Mymensingh"
+BD,13,"Noakhali"
+BD,15,"Patuakhali"
+BD,22,"Bagerhat"
+BD,23,"Bhola"
+BD,24,"Bogra"
+BD,25,"Barguna"
+BD,26,"Brahmanbaria"
+BD,27,"Chandpur"
+BD,28,"Chapai Nawabganj"
+BD,29,"Chattagram"
+BD,30,"Chuadanga"
+BD,31,"Cox's Bazar"
+BD,32,"Dhaka"
+BD,33,"Dinajpur"
+BD,34,"Faridpur"
+BD,35,"Feni"
+BD,36,"Gaibandha"
+BD,37,"Gazipur"
+BD,38,"Gopalganj"
+BD,39,"Habiganj"
+BD,40,"Jaipurhat"
+BD,41,"Jamalpur"
+BD,42,"Jessore"
+BD,43,"Jhalakati"
+BD,44,"Jhenaidah"
+BD,45,"Khagrachari"
+BD,46,"Khulna"
+BD,47,"Kishorganj"
+BD,48,"Kurigram"
+BD,49,"Kushtia"
+BD,50,"Laksmipur"
+BD,51,"Lalmonirhat"
+BD,52,"Madaripur"
+BD,53,"Magura"
+BD,54,"Manikganj"
+BD,55,"Meherpur"
+BD,56,"Moulavibazar"
+BD,57,"Munshiganj"
+BD,58,"Naogaon"
+BD,59,"Narail"
+BD,60,"Narayanganj"
+BD,61,"Narsingdi"
+BD,62,"Nator"
+BD,63,"Netrakona"
+BD,64,"Nilphamari"
+BD,65,"Pabna"
+BD,66,"Panchagar"
+BD,67,"Parbattya Chattagram"
+BD,68,"Pirojpur"
+BD,69,"Rajbari"
+BD,70,"Rajshahi"
+BD,71,"Rangpur"
+BD,72,"Satkhira"
+BD,73,"Shariyatpur"
+BD,74,"Sherpur"
+BD,75,"Sirajganj"
+BD,76,"Sunamganj"
+BD,77,"Sylhet"
+BD,78,"Tangail"
+BD,79,"Thakurgaon"
+BD,81,"Dhaka"
+BD,82,"Khulna"
+BD,83,"Rajshahi"
+BD,84,"Chittagong"
+BD,85,"Barisal"
+BD,86,"Sylhet"
+BE,01,"Antwerpen"
+BE,02,"Brabant"
+BE,03,"Hainaut"
+BE,04,"Liege"
+BE,05,"Limburg"
+BE,06,"Luxembourg"
+BE,07,"Namur"
+BE,08,"Oost-Vlaanderen"
+BE,09,"West-Vlaanderen"
+BE,10,"Brabant Wallon"
+BE,11,"Brussels Hoofdstedelijk Gewest"
+BE,12,"Vlaams-Brabant"
+BF,15,"Bam"
+BF,19,"Boulkiemde"
+BF,20,"Ganzourgou"
+BF,21,"Gnagna"
+BF,28,"Kouritenga"
+BF,33,"Oudalan"
+BF,34,"Passore"
+BF,36,"Sanguie"
+BF,40,"Soum"
+BF,42,"Tapoa"
+BF,44,"Zoundweogo"
+BF,45,"Bale"
+BF,46,"Banwa"
+BF,47,"Bazega"
+BF,48,"Bougouriba"
+BF,49,"Boulgou"
+BF,50,"Gourma"
+BF,51,"Houet"
+BF,52,"Ioba"
+BF,53,"Kadiogo"
+BF,54,"Kenedougou"
+BF,55,"Komoe"
+BF,56,"Komondjari"
+BF,57,"Kompienga"
+BF,58,"Kossi"
+BF,59,"Koulpelogo"
+BF,60,"Kourweogo"
+BF,61,"Leraba"
+BF,62,"Loroum"
+BF,63,"Mouhoun"
+BF,64,"Namentenga"
+BF,65,"Naouri"
+BF,66,"Nayala"
+BF,67,"Noumbiel"
+BF,68,"Oubritenga"
+BF,69,"Poni"
+BF,70,"Sanmatenga"
+BF,71,"Seno"
+BF,72,"Sissili"
+BF,73,"Sourou"
+BF,74,"Tuy"
+BF,75,"Yagha"
+BF,76,"Yatenga"
+BF,77,"Ziro"
+BF,78,"Zondoma"
+BG,33,"Mikhaylovgrad"
+BG,38,"Blagoevgrad"
+BG,39,"Burgas"
+BG,40,"Dobrich"
+BG,41,"Gabrovo"
+BG,42,"Grad Sofiya"
+BG,43,"Khaskovo"
+BG,44,"Kurdzhali"
+BG,45,"Kyustendil"
+BG,46,"Lovech"
+BG,47,"Montana"
+BG,48,"Pazardzhik"
+BG,49,"Pernik"
+BG,50,"Pleven"
+BG,51,"Plovdiv"
+BG,52,"Razgrad"
+BG,53,"Ruse"
+BG,54,"Shumen"
+BG,55,"Silistra"
+BG,56,"Sliven"
+BG,57,"Smolyan"
+BG,58,"Sofiya"
+BG,59,"Stara Zagora"
+BG,60,"Turgovishte"
+BG,61,"Varna"
+BG,62,"Veliko Turnovo"
+BG,63,"Vidin"
+BG,64,"Vratsa"
+BG,65,"Yambol"
+BH,01,"Al Hadd"
+BH,02,"Al Manamah"
+BH,03,"Al Muharraq"
+BH,05,"Jidd Hafs"
+BH,06,"Sitrah"
+BH,08,"Al Mintaqah al Gharbiyah"
+BH,09,"Mintaqat Juzur Hawar"
+BH,10,"Al Mintaqah ash Shamaliyah"
+BH,11,"Al Mintaqah al Wusta"
+BH,12,"Madinat"
+BH,13,"Ar Rifa"
+BH,14,"Madinat Hamad"
+BH,15,"Al Muharraq"
+BH,16,"Al Asimah"
+BH,17,"Al Janubiyah"
+BH,18,"Ash Shamaliyah"
+BH,19,"Al Wusta"
+BI,02,"Bujumbura"
+BI,09,"Bubanza"
+BI,10,"Bururi"
+BI,11,"Cankuzo"
+BI,12,"Cibitoke"
+BI,13,"Gitega"
+BI,14,"Karuzi"
+BI,15,"Kayanza"
+BI,16,"Kirundo"
+BI,17,"Makamba"
+BI,18,"Muyinga"
+BI,19,"Ngozi"
+BI,20,"Rutana"
+BI,21,"Ruyigi"
+BI,22,"Muramvya"
+BI,23,"Mwaro"
+BJ,01,"Atakora"
+BJ,02,"Atlantique"
+BJ,03,"Borgou"
+BJ,04,"Mono"
+BJ,05,"Oueme"
+BJ,06,"Zou"
+BJ,14,"Littoral"
+BM,01,"Devonshire"
+BM,02,"Hamilton"
+BM,03,"Hamilton"
+BM,04,"Paget"
+BM,05,"Pembroke"
+BM,06,"Saint George"
+BM,07,"Saint George's"
+BM,08,"Sandys"
+BM,09,"Smiths"
+BM,10,"Southampton"
+BM,11,"Warwick"
+BN,07,"Alibori"
+BN,08,"Belait"
+BN,09,"Brunei and Muara"
+BN,10,"Temburong"
+BN,11,"Collines"
+BN,12,"Kouffo"
+BN,13,"Donga"
+BN,14,"Littoral"
+BN,15,"Tutong"
+BN,16,"Oueme"
+BN,17,"Plateau"
+BN,18,"Zou"
+BO,01,"Chuquisaca"
+BO,02,"Cochabamba"
+BO,03,"El Beni"
+BO,04,"La Paz"
+BO,05,"Oruro"
+BO,06,"Pando"
+BO,07,"Potosi"
+BO,08,"Santa Cruz"
+BO,09,"Tarija"
+BR,01,"Acre"
+BR,02,"Alagoas"
+BR,03,"Amapa"
+BR,04,"Amazonas"
+BR,05,"Bahia"
+BR,06,"Ceara"
+BR,07,"Distrito Federal"
+BR,08,"Espirito Santo"
+BR,11,"Mato Grosso do Sul"
+BR,13,"Maranhao"
+BR,14,"Mato Grosso"
+BR,15,"Minas Gerais"
+BR,16,"Para"
+BR,17,"Paraiba"
+BR,18,"Parana"
+BR,20,"Piaui"
+BR,21,"Rio de Janeiro"
+BR,22,"Rio Grande do Norte"
+BR,23,"Rio Grande do Sul"
+BR,24,"Rondonia"
+BR,25,"Roraima"
+BR,26,"Santa Catarina"
+BR,27,"Sao Paulo"
+BR,28,"Sergipe"
+BR,29,"Goias"
+BR,30,"Pernambuco"
+BR,31,"Tocantins"
+BS,05,"Bimini"
+BS,06,"Cat Island"
+BS,10,"Exuma"
+BS,13,"Inagua"
+BS,15,"Long Island"
+BS,16,"Mayaguana"
+BS,18,"Ragged Island"
+BS,22,"Harbour Island"
+BS,23,"New Providence"
+BS,24,"Acklins and Crooked Islands"
+BS,25,"Freeport"
+BS,26,"Fresh Creek"
+BS,27,"Governor's Harbour"
+BS,28,"Green Turtle Cay"
+BS,29,"High Rock"
+BS,30,"Kemps Bay"
+BS,31,"Marsh Harbour"
+BS,32,"Nichollstown and Berry Islands"
+BS,33,"Rock Sound"
+BS,34,"Sandy Point"
+BS,35,"San Salvador and Rum Cay"
+BT,05,"Bumthang"
+BT,06,"Chhukha"
+BT,07,"Chirang"
+BT,08,"Daga"
+BT,09,"Geylegphug"
+BT,10,"Ha"
+BT,11,"Lhuntshi"
+BT,12,"Mongar"
+BT,13,"Paro"
+BT,14,"Pemagatsel"
+BT,15,"Punakha"
+BT,16,"Samchi"
+BT,17,"Samdrup"
+BT,18,"Shemgang"
+BT,19,"Tashigang"
+BT,20,"Thimphu"
+BT,21,"Tongsa"
+BT,22,"Wangdi Phodrang"
+BW,01,"Central"
+BW,03,"Ghanzi"
+BW,04,"Kgalagadi"
+BW,05,"Kgatleng"
+BW,06,"Kweneng"
+BW,08,"North-East"
+BW,09,"South-East"
+BW,10,"Southern"
+BW,11,"North-West"
+BY,01,"Brestskaya Voblasts'"
+BY,02,"Homyel'skaya Voblasts'"
+BY,03,"Hrodzyenskaya Voblasts'"
+BY,04,"Minsk"
+BY,05,"Minskaya Voblasts'"
+BY,06,"Mahilyowskaya Voblasts'"
+BY,07,"Vitsyebskaya Voblasts'"
+BZ,01,"Belize"
+BZ,02,"Cayo"
+BZ,03,"Corozal"
+BZ,04,"Orange Walk"
+BZ,05,"Stann Creek"
+BZ,06,"Toledo"
+CA,01,"Alberta"
+CA,02,"British Columbia"
+CA,03,"Manitoba"
+CA,04,"New Brunswick"
+CA,05,"Newfoundland and Labrador"
+CA,07,"Nova Scotia"
+CA,08,"Ontario"
+CA,09,"Prince Edward Island"
+CA,10,"Quebec"
+CA,11,"Saskatchewan"
+CA,12,"Yukon Territory"
+CA,13,"Northwest Territories"
+CA,14,"Nunavut"
+CD,01,"Bandundu"
+CD,02,"Equateur"
+CD,04,"Kasai-Oriental"
+CD,05,"Katanga"
+CD,06,"Kinshasa"
+CD,07,"Kivu"
+CD,08,"Bas-Congo"
+CD,09,"Orientale"
+CD,10,"Maniema"
+CD,11,"Nord-Kivu"
+CD,12,"Sud-Kivu"
+CD,13,"Cuvette"
+CF,01,"Bamingui-Bangoran"
+CF,02,"Basse-Kotto"
+CF,03,"Haute-Kotto"
+CF,04,"Mambere-Kadei"
+CF,05,"Haut-Mbomou"
+CF,06,"Kemo"
+CF,07,"Lobaye"
+CF,08,"Mbomou"
+CF,09,"Nana-Mambere"
+CF,11,"Ouaka"
+CF,12,"Ouham"
+CF,13,"Ouham-Pende"
+CF,14,"Cuvette-Ouest"
+CF,15,"Nana-Grebizi"
+CF,16,"Sangha-Mbaere"
+CF,17,"Ombella-Mpoko"
+CF,18,"Bangui"
+CG,01,"Bouenza"
+CG,03,"Cuvette"
+CG,04,"Kouilou"
+CG,05,"Lekoumou"
+CG,06,"Likouala"
+CG,07,"Niari"
+CG,08,"Plateaux"
+CG,10,"Sangha"
+CG,11,"Pool"
+CG,12,"Brazzaville"
+CH,01,"Aargau"
+CH,02,"Ausser-Rhoden"
+CH,03,"Basel-Landschaft"
+CH,04,"Basel-Stadt"
+CH,05,"Bern"
+CH,06,"Fribourg"
+CH,07,"Geneve"
+CH,08,"Glarus"
+CH,09,"Graubunden"
+CH,10,"Inner-Rhoden"
+CH,11,"Luzern"
+CH,12,"Neuchatel"
+CH,13,"Nidwalden"
+CH,14,"Obwalden"
+CH,15,"Sankt Gallen"
+CH,16,"Schaffhausen"
+CH,17,"Schwyz"
+CH,18,"Solothurn"
+CH,19,"Thurgau"
+CH,20,"Ticino"
+CH,21,"Uri"
+CH,22,"Valais"
+CH,23,"Vaud"
+CH,24,"Zug"
+CH,25,"Zurich"
+CH,26,"Jura"
+CI,51,"Sassandra"
+CI,61,"Abidjan"
+CI,74,"Agneby"
+CI,75,"Bafing"
+CI,76,"Bas-Sassandra"
+CI,77,"Denguele"
+CI,78,"Dix-Huit Montagnes"
+CI,79,"Fromager"
+CI,80,"Haut-Sassandra"
+CI,81,"Lacs"
+CI,82,"Lagunes"
+CI,83,"Marahoue"
+CI,84,"Moyen-Cavally"
+CI,85,"Moyen-Comoe"
+CI,86,"N'zi-Comoe"
+CI,87,"Savanes"
+CI,88,"Sud-Bandama"
+CI,89,"Sud-Comoe"
+CI,90,"Vallee du Bandama"
+CI,91,"Worodougou"
+CI,92,"Zanzan"
+CL,01,"Valparaiso"
+CL,02,"Aisen del General Carlos Ibanez del Campo"
+CL,03,"Antofagasta"
+CL,04,"Araucania"
+CL,05,"Atacama"
+CL,06,"Bio-Bio"
+CL,07,"Coquimbo"
+CL,08,"Libertador General Bernardo O'Higgins"
+CL,09,"Los Lagos"
+CL,10,"Magallanes y de la Antartica Chilena"
+CL,11,"Maule"
+CL,12,"Region Metropolitana"
+CL,13,"Tarapaca"
+CM,04,"Est"
+CM,05,"Littoral"
+CM,07,"Nord-Ouest"
+CM,08,"Ouest"
+CM,09,"Sud-Ouest"
+CM,10,"Adamaoua"
+CM,11,"Centre"
+CM,12,"Extreme-Nord"
+CM,13,"Nord"
+CM,14,"Sud"
+CN,01,"Anhui"
+CN,02,"Zhejiang"
+CN,03,"Jiangxi"
+CN,04,"Jiangsu"
+CN,05,"Jilin"
+CN,06,"Qinghai"
+CN,07,"Fujian"
+CN,08,"Heilongjiang"
+CN,09,"Henan"
+CN,10,"Hebei"
+CN,11,"Hunan"
+CN,12,"Hubei"
+CN,13,"Xinjiang"
+CN,14,"Xizang"
+CN,15,"Gansu"
+CN,16,"Guangxi"
+CN,18,"Guizhou"
+CN,19,"Liaoning"
+CN,20,"Nei Mongol"
+CN,21,"Ningxia"
+CN,22,"Beijing"
+CN,23,"Shanghai"
+CN,24,"Shanxi"
+CN,25,"Shandong"
+CN,26,"Shaanxi"
+CN,28,"Tianjin"
+CN,29,"Yunnan"
+CN,30,"Guangdong"
+CN,31,"Hainan"
+CN,32,"Sichuan"
+CN,33,"Chongqing"
+CO,01,"Amazonas"
+CO,02,"Antioquia"
+CO,03,"Arauca"
+CO,04,"Atlantico"
+CO,05,"Bolívar Department"
+CO,06,"Boyacá Department"
+CO,07,"Caldas Department"
+CO,08,"Caqueta"
+CO,09,"Cauca"
+CO,10,"Cesar"
+CO,11,"Choco"
+CO,12,"Cordoba"
+CO,14,"Guaviare"
+CO,15,"Guainia"
+CO,16,"Huila"
+CO,17,"La Guajira"
+CO,18,"Magdalena Department"
+CO,19,"Meta"
+CO,20,"Narino"
+CO,21,"Norte de Santander"
+CO,22,"Putumayo"
+CO,23,"Quindio"
+CO,24,"Risaralda"
+CO,25,"San Andres y Providencia"
+CO,26,"Santander"
+CO,27,"Sucre"
+CO,28,"Tolima"
+CO,29,"Valle del Cauca"
+CO,30,"Vaupes"
+CO,31,"Vichada"
+CO,32,"Casanare"
+CO,33,"Cundinamarca"
+CO,34,"Distrito Especial"
+CO,35,"Bolivar"
+CO,36,"Boyaca"
+CO,37,"Caldas"
+CO,38,"Magdalena"
+CR,01,"Alajuela"
+CR,02,"Cartago"
+CR,03,"Guanacaste"
+CR,04,"Heredia"
+CR,06,"Limon"
+CR,07,"Puntarenas"
+CR,08,"San Jose"
+CU,01,"Pinar del Rio"
+CU,02,"Ciudad de la Habana"
+CU,03,"Matanzas"
+CU,04,"Isla de la Juventud"
+CU,05,"Camaguey"
+CU,07,"Ciego de Avila"
+CU,08,"Cienfuegos"
+CU,09,"Granma"
+CU,10,"Guantanamo"
+CU,11,"La Habana"
+CU,12,"Holguin"
+CU,13,"Las Tunas"
+CU,14,"Sancti Spiritus"
+CU,15,"Santiago de Cuba"
+CU,16,"Villa Clara"
+CV,01,"Boa Vista"
+CV,02,"Brava"
+CV,04,"Maio"
+CV,05,"Paul"
+CV,07,"Ribeira Grande"
+CV,08,"Sal"
+CV,10,"Sao Nicolau"
+CV,11,"Sao Vicente"
+CV,13,"Mosteiros"
+CV,14,"Praia"
+CV,15,"Santa Catarina"
+CV,16,"Santa Cruz"
+CV,17,"Sao Domingos"
+CV,18,"Sao Filipe"
+CV,19,"Sao Miguel"
+CV,20,"Tarrafal"
+CY,01,"Famagusta"
+CY,02,"Kyrenia"
+CY,03,"Larnaca"
+CY,04,"Nicosia"
+CY,05,"Limassol"
+CY,06,"Paphos"
+CZ,03,"Blansko"
+CZ,04,"Breclav"
+CZ,20,"Hradec Kralove"
+CZ,21,"Jablonec nad Nisou"
+CZ,23,"Jicin"
+CZ,24,"Jihlava"
+CZ,30,"Kolin"
+CZ,33,"Liberec"
+CZ,36,"Melnik"
+CZ,37,"Mlada Boleslav"
+CZ,39,"Nachod"
+CZ,41,"Nymburk"
+CZ,45,"Pardubice"
+CZ,52,"Hlavni mesto Praha"
+CZ,61,"Semily"
+CZ,70,"Trutnov"
+CZ,78,"Jihomoravsky kraj"
+CZ,79,"Jihocesky kraj"
+CZ,80,"Vysocina"
+CZ,81,"Karlovarsky kraj"
+CZ,82,"Kralovehradecky kraj"
+CZ,83,"Liberecky kraj"
+CZ,84,"Olomoucky kraj"
+CZ,85,"Moravskoslezsky kraj"
+CZ,86,"Pardubicky kraj"
+CZ,87,"Plzensky kraj"
+CZ,88,"Stredocesky kraj"
+CZ,89,"Ustecky kraj"
+CZ,90,"Zlinsky kraj"
+DE,01,"Baden-Wurttemberg"
+DE,02,"Bayern"
+DE,03,"Bremen"
+DE,04,"Hamburg"
+DE,05,"Hessen"
+DE,06,"Niedersachsen"
+DE,07,"Nordrhein-Westfalen"
+DE,08,"Rheinland-Pfalz"
+DE,09,"Saarland"
+DE,10,"Schleswig-Holstein"
+DE,11,"Brandenburg"
+DE,12,"Mecklenburg-Vorpommern"
+DE,13,"Sachsen"
+DE,14,"Sachsen-Anhalt"
+DE,15,"Thuringen"
+DE,16,"Berlin"
+DJ,01,"Ali Sabieh"
+DJ,04,"Obock"
+DJ,05,"Tadjoura"
+DJ,06,"Dikhil"
+DJ,07,"Djibouti"
+DJ,08,"Arta"
+DK,01,"Arhus"
+DK,02,"Bornholm"
+DK,03,"Frederiksborg"
+DK,04,"Fyn"
+DK,05,"Kobenhavn"
+DK,06,"Staden Kobenhavn"
+DK,07,"Nordjylland"
+DK,08,"Ribe"
+DK,09,"Ringkobing"
+DK,10,"Roskilde"
+DK,11,"Sonderjylland"
+DK,12,"Storstrom"
+DK,13,"Vejle"
+DK,14,"Vestsjalland"
+DK,15,"Viborg"
+DK,17,"Hovedstaden"
+DK,18,"Midtjyllen"
+DK,19,"Nordjylland"
+DK,20,"Sjelland"
+DK,21,"Syddanmark"
+DM,02,"Saint Andrew"
+DM,03,"Saint David"
+DM,04,"Saint George"
+DM,05,"Saint John"
+DM,06,"Saint Joseph"
+DM,07,"Saint Luke"
+DM,08,"Saint Mark"
+DM,09,"Saint Patrick"
+DM,10,"Saint Paul"
+DM,11,"Saint Peter"
+DO,01,"Azua"
+DO,02,"Baoruco"
+DO,03,"Barahona"
+DO,04,"Dajabon"
+DO,05,"Distrito Nacional"
+DO,06,"Duarte"
+DO,08,"Espaillat"
+DO,09,"Independencia"
+DO,10,"La Altagracia"
+DO,11,"Elias Pina"
+DO,12,"La Romana"
+DO,14,"Maria Trinidad Sanchez"
+DO,15,"Monte Cristi"
+DO,16,"Pedernales"
+DO,17,"Peravia"
+DO,18,"Puerto Plata"
+DO,19,"Salcedo"
+DO,20,"Samana"
+DO,21,"Sanchez Ramirez"
+DO,23,"San Juan"
+DO,24,"San Pedro De Macoris"
+DO,25,"Santiago"
+DO,26,"Santiago Rodriguez"
+DO,27,"Valverde"
+DO,28,"El Seibo"
+DO,29,"Hato Mayor"
+DO,30,"La Vega"
+DO,31,"Monsenor Nouel"
+DO,32,"Monte Plata"
+DO,33,"San Cristobal"
+DO,34,"Distrito Nacional"
+DO,35,"Peravia"
+DO,36,"San Jose de Ocoa"
+DO,37,"Santo Domingo"
+DZ,01,"Alger"
+DZ,03,"Batna"
+DZ,04,"Constantine"
+DZ,06,"Medea"
+DZ,07,"Mostaganem"
+DZ,09,"Oran"
+DZ,10,"Saida"
+DZ,12,"Setif"
+DZ,13,"Tiaret"
+DZ,14,"Tizi Ouzou"
+DZ,15,"Tlemcen"
+DZ,18,"Bejaia"
+DZ,19,"Biskra"
+DZ,20,"Blida"
+DZ,21,"Bouira"
+DZ,22,"Djelfa"
+DZ,23,"Guelma"
+DZ,24,"Jijel"
+DZ,25,"Laghouat"
+DZ,26,"Mascara"
+DZ,27,"M'sila"
+DZ,29,"Oum el Bouaghi"
+DZ,30,"Sidi Bel Abbes"
+DZ,31,"Skikda"
+DZ,33,"Tebessa"
+DZ,34,"Adrar"
+DZ,35,"Ain Defla"
+DZ,36,"Ain Temouchent"
+DZ,37,"Annaba"
+DZ,38,"Bechar"
+DZ,39,"Bordj Bou Arreridj"
+DZ,40,"Boumerdes"
+DZ,41,"Chlef"
+DZ,42,"El Bayadh"
+DZ,43,"El Oued"
+DZ,44,"El Tarf"
+DZ,45,"Ghardaia"
+DZ,46,"Illizi"
+DZ,47,"Khenchela"
+DZ,48,"Mila"
+DZ,49,"Naama"
+DZ,50,"Ouargla"
+DZ,51,"Relizane"
+DZ,52,"Souk Ahras"
+DZ,53,"Tamanghasset"
+DZ,54,"Tindouf"
+DZ,55,"Tipaza"
+DZ,56,"Tissemsilt"
+EC,01,"Galapagos"
+EC,02,"Azuay"
+EC,03,"Bolivar"
+EC,04,"Canar"
+EC,05,"Carchi"
+EC,06,"Chimborazo"
+EC,07,"Cotopaxi"
+EC,08,"El Oro"
+EC,09,"Esmeraldas"
+EC,10,"Guayas"
+EC,11,"Imbabura"
+EC,12,"Loja"
+EC,13,"Los Rios"
+EC,14,"Manabi"
+EC,15,"Morona-Santiago"
+EC,17,"Pastaza"
+EC,18,"Pichincha"
+EC,19,"Tungurahua"
+EC,20,"Zamora-Chinchipe"
+EC,22,"Sucumbios"
+EC,23,"Napo"
+EC,24,"Orellana"
+EE,01,"Harjumaa"
+EE,02,"Hiiumaa"
+EE,03,"Ida-Virumaa"
+EE,04,"Jarvamaa"
+EE,05,"Jogevamaa"
+EE,06,"Kohtla-Jarve"
+EE,07,"Laanemaa"
+EE,08,"Laane-Virumaa"
+EE,09,"Narva"
+EE,10,"Parnu"
+EE,11,"Parnumaa"
+EE,12,"Polvamaa"
+EE,13,"Raplamaa"
+EE,14,"Saaremaa"
+EE,15,"Sillamae"
+EE,16,"Tallinn"
+EE,17,"Tartu"
+EE,18,"Tartumaa"
+EE,19,"Valgamaa"
+EE,20,"Viljandimaa"
+EE,21,"Vorumaa"
+EG,01,"Ad Daqahliyah"
+EG,02,"Al Bahr al Ahmar"
+EG,03,"Al Buhayrah"
+EG,04,"Al Fayyum"
+EG,05,"Al Gharbiyah"
+EG,06,"Al Iskandariyah"
+EG,07,"Al Isma'iliyah"
+EG,08,"Al Jizah"
+EG,09,"Al Minufiyah"
+EG,10,"Al Minya"
+EG,11,"Al Qahirah"
+EG,12,"Al Qalyubiyah"
+EG,13,"Al Wadi al Jadid"
+EG,14,"Ash Sharqiyah"
+EG,15,"As Suways"
+EG,16,"Aswan"
+EG,17,"Asyut"
+EG,18,"Bani Suwayf"
+EG,19,"Bur Sa'id"
+EG,20,"Dumyat"
+EG,21,"Kafr ash Shaykh"
+EG,22,"Matruh"
+EG,23,"Qina"
+EG,24,"Suhaj"
+EG,26,"Janub Sina'"
+EG,27,"Shamal Sina'"
+ER,01,"Anseba"
+ER,02,"Debub"
+ER,03,"Debubawi K'eyih Bahri"
+ER,04,"Gash Barka"
+ER,05,"Ma'akel"
+ER,06,"Semenawi K'eyih Bahri"
+ES,07,"Islas Baleares"
+ES,27,"La Rioja"
+ES,29,"Madrid"
+ES,31,"Murcia"
+ES,32,"Navarra"
+ES,34,"Asturias"
+ES,39,"Cantabria"
+ES,51,"Andalucia"
+ES,52,"Aragon"
+ES,53,"Canarias"
+ES,54,"Castilla-La Mancha"
+ES,55,"Castilla y Leon"
+ES,56,"Catalonia"
+ES,57,"Extremadura"
+ES,58,"Galicia"
+ES,59,"Pais Vasco"
+ES,60,"Comunidad Valenciana"
+ET,02,"Amhara"
+ET,07,"Somali"
+ET,08,"Gambella"
+ET,10,"Addis Abeba"
+ET,11,"Southern"
+ET,12,"Tigray"
+ET,13,"Benishangul"
+ET,14,"Afar"
+ET,44,"Adis Abeba"
+ET,45,"Afar"
+ET,46,"Amara"
+ET,47,"Binshangul Gumuz"
+ET,48,"Dire Dawa"
+ET,49,"Gambela Hizboch"
+ET,50,"Hareri Hizb"
+ET,51,"Oromiya"
+ET,52,"Sumale"
+ET,53,"Tigray"
+ET,54,"YeDebub Biheroch Bihereseboch na Hizboch"
+FI,01,"Aland"
+FI,06,"Lapland"
+FI,08,"Oulu"
+FI,13,"Southern Finland"
+FI,14,"Eastern Finland"
+FI,15,"Western Finland"
+FJ,01,"Central"
+FJ,02,"Eastern"
+FJ,03,"Northern"
+FJ,04,"Rotuma"
+FJ,05,"Western"
+FM,01,"Kosrae"
+FM,02,"Pohnpei"
+FM,03,"Chuuk"
+FM,04,"Yap"
+FR,97,"Aquitaine"
+FR,98,"Auvergne"
+FR,99,"Basse-Normandie"
+FR,A1,"Bourgogne"
+FR,A2,"Bretagne"
+FR,A3,"Centre"
+FR,A4,"Champagne-Ardenne"
+FR,A5,"Corse"
+FR,A6,"Franche-Comte"
+FR,A7,"Haute-Normandie"
+FR,A8,"Ile-de-France"
+FR,A9,"Languedoc-Roussillon"
+FR,B1,"Limousin"
+FR,B2,"Lorraine"
+FR,B3,"Midi-Pyrenees"
+FR,B4,"Nord-Pas-de-Calais"
+FR,B5,"Pays de la Loire"
+FR,B6,"Picardie"
+FR,B7,"Poitou-Charentes"
+FR,B8,"Provence-Alpes-Cote d'Azur"
+FR,B9,"Rhone-Alpes"
+FR,C1,"Alsace"
+GA,01,"Estuaire"
+GA,02,"Haut-Ogooue"
+GA,03,"Moyen-Ogooue"
+GA,04,"Ngounie"
+GA,05,"Nyanga"
+GA,06,"Ogooue-Ivindo"
+GA,07,"Ogooue-Lolo"
+GA,08,"Ogooue-Maritime"
+GA,09,"Woleu-Ntem"
+GB,01,"Avon"
+GB,03,"Berkshire"
+GB,07,"Cleveland"
+GB,17,"Greater London"
+GB,18,"Greater Manchester"
+GB,20,"Hereford and Worcester"
+GB,22,"Humberside"
+GB,28,"Merseyside"
+GB,37,"South Yorkshire"
+GB,41,"Tyne and Wear"
+GB,43,"West Midlands"
+GB,45,"West Yorkshire"
+GB,79,"Central"
+GB,82,"Grampian"
+GB,84,"Lothian"
+GB,87,"Strathclyde"
+GB,88,"Tayside"
+GB,90,"Clwyd"
+GB,91,"Dyfed"
+GB,92,"Gwent"
+GB,94,"Mid Glamorgan"
+GB,96,"South Glamorgan"
+GB,97,"West Glamorgan"
+GB,A1,"Barking and Dagenham"
+GB,A2,"Barnet"
+GB,A3,"Barnsley"
+GB,A4,"Bath and North East Somerset"
+GB,A5,"Bedfordshire"
+GB,A6,"Bexley"
+GB,A7,"Birmingham"
+GB,A8,"Blackburn with Darwen"
+GB,A9,"Blackpool"
+GB,B1,"Bolton"
+GB,B2,"Bournemouth"
+GB,B3,"Bracknell Forest"
+GB,B4,"Bradford"
+GB,B5,"Brent"
+GB,B6,"Brighton and Hove"
+GB,B7,"Bristol, City of"
+GB,B8,"Bromley"
+GB,B9,"Buckinghamshire"
+GB,C1,"Bury"
+GB,C2,"Calderdale"
+GB,C3,"Cambridgeshire"
+GB,C4,"Camden"
+GB,C5,"Cheshire"
+GB,C6,"Cornwall"
+GB,C7,"Coventry"
+GB,C8,"Croydon"
+GB,C9,"Cumbria"
+GB,D1,"Darlington"
+GB,D2,"Derby"
+GB,D3,"Derbyshire"
+GB,D4,"Devon"
+GB,D5,"Doncaster"
+GB,D6,"Dorset"
+GB,D7,"Dudley"
+GB,D8,"Durham"
+GB,D9,"Ealing"
+GB,E1,"East Riding of Yorkshire"
+GB,E2,"East Sussex"
+GB,E3,"Enfield"
+GB,E4,"Essex"
+GB,E5,"Gateshead"
+GB,E6,"Gloucestershire"
+GB,E7,"Greenwich"
+GB,E8,"Hackney"
+GB,E9,"Halton"
+GB,F1,"Hammersmith and Fulham"
+GB,F2,"Hampshire"
+GB,F3,"Haringey"
+GB,F4,"Harrow"
+GB,F5,"Hartlepool"
+GB,F6,"Havering"
+GB,F7,"Herefordshire"
+GB,F8,"Hertford"
+GB,F9,"Hillingdon"
+GB,G1,"Hounslow"
+GB,G2,"Isle of Wight"
+GB,G3,"Islington"
+GB,G4,"Kensington and Chelsea"
+GB,G5,"Kent"
+GB,G6,"Kingston upon Hull, City of"
+GB,G7,"Kingston upon Thames"
+GB,G8,"Kirklees"
+GB,G9,"Knowsley"
+GB,H1,"Lambeth"
+GB,H2,"Lancashire"
+GB,H3,"Leeds"
+GB,H4,"Leicester"
+GB,H5,"Leicestershire"
+GB,H6,"Lewisham"
+GB,H7,"Lincolnshire"
+GB,H8,"Liverpool"
+GB,H9,"London, City of"
+GB,I1,"Luton"
+GB,I2,"Manchester"
+GB,I3,"Medway"
+GB,I4,"Merton"
+GB,I5,"Middlesbrough"
+GB,I6,"Milton Keynes"
+GB,I7,"Newcastle upon Tyne"
+GB,I8,"Newham"
+GB,I9,"Norfolk"
+GB,J1,"Northamptonshire"
+GB,J2,"North East Lincolnshire"
+GB,J3,"North Lincolnshire"
+GB,J4,"North Somerset"
+GB,J5,"North Tyneside"
+GB,J6,"Northumberland"
+GB,J7,"North Yorkshire"
+GB,J8,"Nottingham"
+GB,J9,"Nottinghamshire"
+GB,K1,"Oldham"
+GB,K2,"Oxfordshire"
+GB,K3,"Peterborough"
+GB,K4,"Plymouth"
+GB,K5,"Poole"
+GB,K6,"Portsmouth"
+GB,K7,"Reading"
+GB,K8,"Redbridge"
+GB,K9,"Redcar and Cleveland"
+GB,L1,"Richmond upon Thames"
+GB,L2,"Rochdale"
+GB,L3,"Rotherham"
+GB,L4,"Rutland"
+GB,L5,"Salford"
+GB,L6,"Shropshire"
+GB,L7,"Sandwell"
+GB,L8,"Sefton"
+GB,L9,"Sheffield"
+GB,M1,"Slough"
+GB,M2,"Solihull"
+GB,M3,"Somerset"
+GB,M4,"Southampton"
+GB,M5,"Southend-on-Sea"
+GB,M6,"South Gloucestershire"
+GB,M7,"South Tyneside"
+GB,M8,"Southwark"
+GB,M9,"Staffordshire"
+GB,N1,"St. Helens"
+GB,N2,"Stockport"
+GB,N3,"Stockton-on-Tees"
+GB,N4,"Stoke-on-Trent"
+GB,N5,"Suffolk"
+GB,N6,"Sunderland"
+GB,N7,"Surrey"
+GB,N8,"Sutton"
+GB,N9,"Swindon"
+GB,O1,"Tameside"
+GB,O2,"Telford and Wrekin"
+GB,O3,"Thurrock"
+GB,O4,"Torbay"
+GB,O5,"Tower Hamlets"
+GB,O6,"Trafford"
+GB,O7,"Wakefield"
+GB,O8,"Walsall"
+GB,O9,"Waltham Forest"
+GB,P1,"Wandsworth"
+GB,P2,"Warrington"
+GB,P3,"Warwickshire"
+GB,P4,"West Berkshire"
+GB,P5,"Westminster"
+GB,P6,"West Sussex"
+GB,P7,"Wigan"
+GB,P8,"Wiltshire"
+GB,P9,"Windsor and Maidenhead"
+GB,Q1,"Wirral"
+GB,Q2,"Wokingham"
+GB,Q3,"Wolverhampton"
+GB,Q4,"Worcestershire"
+GB,Q5,"York"
+GB,Q6,"Antrim"
+GB,Q7,"Ards"
+GB,Q8,"Armagh"
+GB,Q9,"Ballymena"
+GB,R1,"Ballymoney"
+GB,R2,"Banbridge"
+GB,R3,"Belfast"
+GB,R4,"Carrickfergus"
+GB,R5,"Castlereagh"
+GB,R6,"Coleraine"
+GB,R7,"Cookstown"
+GB,R8,"Craigavon"
+GB,R9,"Down"
+GB,S1,"Dungannon"
+GB,S2,"Fermanagh"
+GB,S3,"Larne"
+GB,S4,"Limavady"
+GB,S5,"Lisburn"
+GB,S6,"Derry"
+GB,S7,"Magherafelt"
+GB,S8,"Moyle"
+GB,S9,"Newry and Mourne"
+GB,T1,"Newtownabbey"
+GB,T2,"North Down"
+GB,T3,"Omagh"
+GB,T4,"Strabane"
+GB,T5,"Aberdeen City"
+GB,T6,"Aberdeenshire"
+GB,T7,"Angus"
+GB,T8,"Argyll and Bute"
+GB,T9,"Scottish Borders, The"
+GB,U1,"Clackmannanshire"
+GB,U2,"Dumfries and Galloway"
+GB,U3,"Dundee City"
+GB,U4,"East Ayrshire"
+GB,U5,"East Dunbartonshire"
+GB,U6,"East Lothian"
+GB,U7,"East Renfrewshire"
+GB,U8,"Edinburgh, City of"
+GB,U9,"Falkirk"
+GB,V1,"Fife"
+GB,V2,"Glasgow City"
+GB,V3,"Highland"
+GB,V4,"Inverclyde"
+GB,V5,"Midlothian"
+GB,V6,"Moray"
+GB,V7,"North Ayrshire"
+GB,V8,"North Lanarkshire"
+GB,V9,"Orkney"
+GB,W1,"Perth and Kinross"
+GB,W2,"Renfrewshire"
+GB,W3,"Shetland Islands"
+GB,W4,"South Ayrshire"
+GB,W5,"South Lanarkshire"
+GB,W6,"Stirling"
+GB,W7,"West Dunbartonshire"
+GB,W8,"Eilean Siar"
+GB,W9,"West Lothian"
+GB,X1,"Isle of Anglesey"
+GB,X2,"Blaenau Gwent"
+GB,X3,"Bridgend"
+GB,X4,"Caerphilly"
+GB,X5,"Cardiff"
+GB,X6,"Ceredigion"
+GB,X7,"Carmarthenshire"
+GB,X8,"Conwy"
+GB,X9,"Denbighshire"
+GB,Y1,"Flintshire"
+GB,Y2,"Gwynedd"
+GB,Y3,"Merthyr Tydfil"
+GB,Y4,"Monmouthshire"
+GB,Y5,"Neath Port Talbot"
+GB,Y6,"Newport"
+GB,Y7,"Pembrokeshire"
+GB,Y8,"Powys"
+GB,Y9,"Rhondda Cynon Taff"
+GB,Z1,"Swansea"
+GB,Z2,"Torfaen"
+GB,Z3,"Vale of Glamorgan, The"
+GB,Z4,"Wrexham"
+GD,01,"Saint Andrew"
+GD,02,"Saint David"
+GD,03,"Saint George"
+GD,04,"Saint John"
+GD,05,"Saint Mark"
+GD,06,"Saint Patrick"
+GE,01,"Abashis Raioni"
+GE,02,"Abkhazia"
+GE,03,"Adigenis Raioni"
+GE,04,"Ajaria"
+GE,05,"Akhalgoris Raioni"
+GE,06,"Akhalk'alak'is Raioni"
+GE,07,"Akhalts'ikhis Raioni"
+GE,08,"Akhmetis Raioni"
+GE,09,"Ambrolauris Raioni"
+GE,10,"Aspindzis Raioni"
+GE,11,"Baghdat'is Raioni"
+GE,12,"Bolnisis Raioni"
+GE,13,"Borjomis Raioni"
+GE,14,"Chiat'ura"
+GE,15,"Ch'khorotsqus Raioni"
+GE,16,"Ch'okhatauris Raioni"
+GE,17,"Dedop'listsqaros Raioni"
+GE,18,"Dmanisis Raioni"
+GE,19,"Dushet'is Raioni"
+GE,20,"Gardabanis Raioni"
+GE,21,"Gori"
+GE,22,"Goris Raioni"
+GE,23,"Gurjaanis Raioni"
+GE,24,"Javis Raioni"
+GE,25,"K'arelis Raioni"
+GE,26,"Kaspis Raioni"
+GE,27,"Kharagaulis Raioni"
+GE,28,"Khashuris Raioni"
+GE,29,"Khobis Raioni"
+GE,30,"Khonis Raioni"
+GE,31,"K'ut'aisi"
+GE,32,"Lagodekhis Raioni"
+GE,33,"Lanch'khut'is Raioni"
+GE,34,"Lentekhis Raioni"
+GE,35,"Marneulis Raioni"
+GE,36,"Martvilis Raioni"
+GE,37,"Mestiis Raioni"
+GE,38,"Mts'khet'is Raioni"
+GE,39,"Ninotsmindis Raioni"
+GE,40,"Onis Raioni"
+GE,41,"Ozurget'is Raioni"
+GE,42,"P'ot'i"
+GE,43,"Qazbegis Raioni"
+GE,44,"Qvarlis Raioni"
+GE,45,"Rust'avi"
+GE,46,"Sach'kheris Raioni"
+GE,47,"Sagarejos Raioni"
+GE,48,"Samtrediis Raioni"
+GE,49,"Senakis Raioni"
+GE,50,"Sighnaghis Raioni"
+GE,51,"T'bilisi"
+GE,52,"T'elavis Raioni"
+GE,53,"T'erjolis Raioni"
+GE,54,"T'et'ritsqaros Raioni"
+GE,55,"T'ianet'is Raioni"
+GE,56,"Tqibuli"
+GE,57,"Ts'ageris Raioni"
+GE,58,"Tsalenjikhis Raioni"
+GE,59,"Tsalkis Raioni"
+GE,60,"Tsqaltubo"
+GE,61,"Vanis Raioni"
+GE,62,"Zestap'onis Raioni"
+GE,63,"Zugdidi"
+GE,64,"Zugdidis Raioni"
+GH,01,"Greater Accra"
+GH,02,"Ashanti"
+GH,03,"Brong-Ahafo"
+GH,04,"Central"
+GH,05,"Eastern"
+GH,06,"Northern"
+GH,08,"Volta"
+GH,09,"Western"
+GH,10,"Upper East"
+GH,11,"Upper West"
+GL,01,"Nordgronland"
+GL,02,"Ostgronland"
+GL,03,"Vestgronland"
+GM,01,"Banjul"
+GM,02,"Lower River"
+GM,03,"Central River"
+GM,04,"Upper River"
+GM,05,"Western"
+GM,07,"North Bank"
+GN,01,"Beyla"
+GN,02,"Boffa"
+GN,03,"Boke"
+GN,04,"Conakry"
+GN,05,"Dabola"
+GN,06,"Dalaba"
+GN,07,"Dinguiraye"
+GN,09,"Faranah"
+GN,10,"Forecariah"
+GN,11,"Fria"
+GN,12,"Gaoual"
+GN,13,"Gueckedou"
+GN,15,"Kerouane"
+GN,16,"Kindia"
+GN,17,"Kissidougou"
+GN,18,"Koundara"
+GN,19,"Kouroussa"
+GN,21,"Macenta"
+GN,22,"Mali"
+GN,23,"Mamou"
+GN,25,"Pita"
+GN,27,"Telimele"
+GN,28,"Tougue"
+GN,29,"Yomou"
+GN,30,"Coyah"
+GN,31,"Dubreka"
+GN,32,"Kankan"
+GN,33,"Koubia"
+GN,34,"Labe"
+GN,35,"Lelouma"
+GN,36,"Lola"
+GN,37,"Mandiana"
+GN,38,"Nzerekore"
+GN,39,"Siguiri"
+GQ,03,"Annobon"
+GQ,04,"Bioko Norte"
+GQ,05,"Bioko Sur"
+GQ,06,"Centro Sur"
+GQ,07,"Kie-Ntem"
+GQ,08,"Litoral"
+GQ,09,"Wele-Nzas"
+GR,01,"Evros"
+GR,02,"Rodhopi"
+GR,03,"Xanthi"
+GR,04,"Drama"
+GR,05,"Serrai"
+GR,06,"Kilkis"
+GR,07,"Pella"
+GR,08,"Florina"
+GR,09,"Kastoria"
+GR,10,"Grevena"
+GR,11,"Kozani"
+GR,12,"Imathia"
+GR,13,"Thessaloniki"
+GR,14,"Kavala"
+GR,15,"Khalkidhiki"
+GR,16,"Pieria"
+GR,17,"Ioannina"
+GR,18,"Thesprotia"
+GR,19,"Preveza"
+GR,20,"Arta"
+GR,21,"Larisa"
+GR,22,"Trikala"
+GR,23,"Kardhitsa"
+GR,24,"Magnisia"
+GR,25,"Kerkira"
+GR,26,"Levkas"
+GR,27,"Kefallinia"
+GR,28,"Zakinthos"
+GR,29,"Fthiotis"
+GR,30,"Evritania"
+GR,31,"Aitolia kai Akarnania"
+GR,32,"Fokis"
+GR,33,"Voiotia"
+GR,34,"Evvoia"
+GR,35,"Attiki"
+GR,36,"Argolis"
+GR,37,"Korinthia"
+GR,38,"Akhaia"
+GR,39,"Ilia"
+GR,40,"Messinia"
+GR,41,"Arkadhia"
+GR,42,"Lakonia"
+GR,43,"Khania"
+GR,44,"Rethimni"
+GR,45,"Iraklion"
+GR,46,"Lasithi"
+GR,47,"Dhodhekanisos"
+GR,48,"Samos"
+GR,49,"Kikladhes"
+GR,50,"Khios"
+GR,51,"Lesvos"
+GT,01,"Alta Verapaz"
+GT,02,"Baja Verapaz"
+GT,03,"Chimaltenango"
+GT,04,"Chiquimula"
+GT,05,"El Progreso"
+GT,06,"Escuintla"
+GT,07,"Guatemala"
+GT,08,"Huehuetenango"
+GT,09,"Izabal"
+GT,10,"Jalapa"
+GT,11,"Jutiapa"
+GT,12,"Peten"
+GT,13,"Quetzaltenango"
+GT,14,"Quiche"
+GT,15,"Retalhuleu"
+GT,16,"Sacatepequez"
+GT,17,"San Marcos"
+GT,18,"Santa Rosa"
+GT,19,"Solola"
+GT,20,"Suchitepequez"
+GT,21,"Totonicapan"
+GT,22,"Zacapa"
+GW,01,"Bafata"
+GW,02,"Quinara"
+GW,04,"Oio"
+GW,05,"Bolama"
+GW,06,"Cacheu"
+GW,07,"Tombali"
+GW,10,"Gabu"
+GW,11,"Bissau"
+GW,12,"Biombo"
+GY,10,"Barima-Waini"
+GY,11,"Cuyuni-Mazaruni"
+GY,12,"Demerara-Mahaica"
+GY,13,"East Berbice-Corentyne"
+GY,14,"Essequibo Islands-West Demerara"
+GY,15,"Mahaica-Berbice"
+GY,16,"Pomeroon-Supenaam"
+GY,17,"Potaro-Siparuni"
+GY,18,"Upper Demerara-Berbice"
+GY,19,"Upper Takutu-Upper Essequibo"
+HN,01,"Atlantida"
+HN,02,"Choluteca"
+HN,03,"Colon"
+HN,04,"Comayagua"
+HN,05,"Copan"
+HN,06,"Cortes"
+HN,07,"El Paraiso"
+HN,08,"Francisco Morazan"
+HN,09,"Gracias a Dios"
+HN,10,"Intibuca"
+HN,11,"Islas de la Bahia"
+HN,12,"La Paz"
+HN,13,"Lempira"
+HN,14,"Ocotepeque"
+HN,15,"Olancho"
+HN,16,"Santa Barbara"
+HN,17,"Valle"
+HN,18,"Yoro"
+HR,01,"Bjelovarsko-Bilogorska"
+HR,02,"Brodsko-Posavska"
+HR,03,"Dubrovacko-Neretvanska"
+HR,04,"Istarska"
+HR,05,"Karlovacka"
+HR,06,"Koprivnicko-Krizevacka"
+HR,07,"Krapinsko-Zagorska"
+HR,08,"Licko-Senjska"
+HR,09,"Medimurska"
+HR,10,"Osjecko-Baranjska"
+HR,11,"Pozesko-Slavonska"
+HR,12,"Primorsko-Goranska"
+HR,13,"Sibensko-Kninska"
+HR,14,"Sisacko-Moslavacka"
+HR,15,"Splitsko-Dalmatinska"
+HR,16,"Varazdinska"
+HR,17,"Viroviticko-Podravska"
+HR,18,"Vukovarsko-Srijemska"
+HR,19,"Zadarska"
+HR,20,"Zagrebacka"
+HR,21,"Grad Zagreb"
+HT,03,"Nord-Ouest"
+HT,06,"Artibonite"
+HT,07,"Centre"
+HT,09,"Nord"
+HT,10,"Nord-Est"
+HT,11,"Ouest"
+HT,12,"Sud"
+HT,13,"Sud-Est"
+HT,14,"Grand' Anse"
+HT,15,"Nippes"
+HU,01,"Bacs-Kiskun"
+HU,02,"Baranya"
+HU,03,"Bekes"
+HU,04,"Borsod-Abauj-Zemplen"
+HU,05,"Budapest"
+HU,06,"Csongrad"
+HU,07,"Debrecen"
+HU,08,"Fejer"
+HU,09,"Gyor-Moson-Sopron"
+HU,10,"Hajdu-Bihar"
+HU,11,"Heves"
+HU,12,"Komarom-Esztergom"
+HU,13,"Miskolc"
+HU,14,"Nograd"
+HU,15,"Pecs"
+HU,16,"Pest"
+HU,17,"Somogy"
+HU,18,"Szabolcs-Szatmar-Bereg"
+HU,19,"Szeged"
+HU,20,"Jasz-Nagykun-Szolnok"
+HU,21,"Tolna"
+HU,22,"Vas"
+HU,23,"Veszprem"
+HU,24,"Zala"
+HU,25,"Gyor"
+HU,26,"Bekescsaba"
+HU,27,"Dunaujvaros"
+HU,28,"Eger"
+HU,29,"Hodmezovasarhely"
+HU,30,"Kaposvar"
+HU,31,"Kecskemet"
+HU,32,"Nagykanizsa"
+HU,33,"Nyiregyhaza"
+HU,34,"Sopron"
+HU,35,"Szekesfehervar"
+HU,36,"Szolnok"
+HU,37,"Szombathely"
+HU,38,"Tatabanya"
+HU,39,"Veszprem"
+HU,40,"Zalaegerszeg"
+HU,41,"Salgotarjan"
+HU,42,"Szekszard"
+ID,01,"Aceh"
+ID,02,"Bali"
+ID,03,"Bengkulu"
+ID,04,"Jakarta Raya"
+ID,05,"Jambi"
+ID,06,"Jawa Barat"
+ID,07,"Jawa Tengah"
+ID,08,"Jawa Timur"
+ID,09,"Papua"
+ID,10,"Yogyakarta"
+ID,11,"Kalimantan Barat"
+ID,12,"Kalimantan Selatan"
+ID,13,"Kalimantan Tengah"
+ID,14,"Kalimantan Timur"
+ID,15,"Lampung"
+ID,16,"Maluku"
+ID,17,"Nusa Tenggara Barat"
+ID,18,"Nusa Tenggara Timur"
+ID,19,"Riau"
+ID,20,"Sulawesi Selatan"
+ID,21,"Sulawesi Tengah"
+ID,22,"Sulawesi Tenggara"
+ID,23,"Sulawesi Utara"
+ID,24,"Sumatera Barat"
+ID,25,"Sumatera Selatan"
+ID,26,"Sumatera Utara"
+ID,28,"Maluku"
+ID,29,"Maluku Utara"
+ID,30,"Jawa Barat"
+ID,31,"Sulawesi Utara"
+ID,32,"Sumatera Selatan"
+ID,33,"Banten"
+ID,34,"Gorontalo"
+ID,35,"Kepulauan Bangka Belitung"
+ID,36,"Papua"
+ID,37,"Riau"
+ID,38,"Sulawesi Selatan"
+ID,39,"Irian Jaya Barat"
+ID,40,"Kepulauan Riau"
+ID,41,"Sulawesi Barat"
+IE,01,"Carlow"
+IE,02,"Cavan"
+IE,03,"Clare"
+IE,04,"Cork"
+IE,06,"Donegal"
+IE,07,"Dublin"
+IE,10,"Galway"
+IE,11,"Kerry"
+IE,12,"Kildare"
+IE,13,"Kilkenny"
+IE,14,"Leitrim"
+IE,15,"Laois"
+IE,16,"Limerick"
+IE,18,"Longford"
+IE,19,"Louth"
+IE,20,"Mayo"
+IE,21,"Meath"
+IE,22,"Monaghan"
+IE,23,"Offaly"
+IE,24,"Roscommon"
+IE,25,"Sligo"
+IE,26,"Tipperary"
+IE,27,"Waterford"
+IE,29,"Westmeath"
+IE,30,"Wexford"
+IE,31,"Wicklow"
+IL,01,"HaDarom"
+IL,02,"HaMerkaz"
+IL,03,"HaZafon"
+IL,04,"Hefa"
+IL,05,"Tel Aviv"
+IL,06,"Yerushalayim"
+IN,01,"Andaman and Nicobar Islands"
+IN,02,"Andhra Pradesh"
+IN,03,"Assam"
+IN,05,"Chandigarh"
+IN,06,"Dadra and Nagar Haveli"
+IN,07,"Delhi"
+IN,09,"Gujarat"
+IN,10,"Haryana"
+IN,11,"Himachal Pradesh"
+IN,12,"Jammu and Kashmir"
+IN,13,"Kerala"
+IN,14,"Lakshadweep"
+IN,16,"Maharashtra"
+IN,17,"Manipur"
+IN,18,"Meghalaya"
+IN,19,"Karnataka"
+IN,20,"Nagaland"
+IN,21,"Orissa"
+IN,22,"Puducherry"
+IN,23,"Punjab"
+IN,24,"Rajasthan"
+IN,25,"Tamil Nadu"
+IN,26,"Tripura"
+IN,28,"West Bengal"
+IN,29,"Sikkim"
+IN,30,"Arunachal Pradesh"
+IN,31,"Mizoram"
+IN,32,"Daman and Diu"
+IN,33,"Goa"
+IN,34,"Bihar"
+IN,35,"Madhya Pradesh"
+IN,36,"Uttar Pradesh"
+IN,37,"Chhattisgarh"
+IN,38,"Jharkhand"
+IN,39,"Uttarakhand"
+IQ,01,"Al Anbar"
+IQ,02,"Al Basrah"
+IQ,03,"Al Muthanna"
+IQ,04,"Al Qadisiyah"
+IQ,05,"As Sulaymaniyah"
+IQ,06,"Babil"
+IQ,07,"Baghdad"
+IQ,08,"Dahuk"
+IQ,09,"Dhi Qar"
+IQ,10,"Diyala"
+IQ,11,"Arbil"
+IQ,12,"Karbala'"
+IQ,13,"At Ta'mim"
+IQ,14,"Maysan"
+IQ,15,"Ninawa"
+IQ,16,"Wasit"
+IQ,17,"An Najaf"
+IQ,18,"Salah ad Din"
+IR,01,"Azarbayjan-e Bakhtari"
+IR,02,"Azarbayjan-e Khavari"
+IR,03,"Chahar Mahall va Bakhtiari"
+IR,04,"Sistan va Baluchestan"
+IR,05,"Kohkiluyeh va Buyer Ahmadi"
+IR,07,"Fars"
+IR,08,"Gilan"
+IR,09,"Hamadan"
+IR,10,"Ilam"
+IR,11,"Hormozgan"
+IR,12,"Kerman"
+IR,13,"Bakhtaran"
+IR,15,"Khuzestan"
+IR,16,"Kordestan"
+IR,17,"Mazandaran"
+IR,18,"Semnān Province"
+IR,19,"Markazi"
+IR,21,"Zanjan"
+IR,22,"Bushehr"
+IR,23,"Lorestan"
+IR,24,"Markazi"
+IR,25,"Semnan"
+IR,26,"Tehran"
+IR,27,"Zanjan"
+IR,28,"Esfahan"
+IR,29,"Kerman"
+IR,30,"Khorasan"
+IR,31,"Yazd"
+IR,32,"Ardabil"
+IR,33,"East Azarbaijan"
+IR,34,"Markazi"
+IR,35,"Mazandaran"
+IR,36,"Zanjan"
+IR,37,"Golestan"
+IR,38,"Qazvin"
+IR,39,"Qom"
+IR,40,"Yazd"
+IR,41,"Khorasan-e Janubi"
+IR,42,"Khorasan-e Razavi"
+IR,43,"Khorasan-e Shemali"
+IS,03,"Arnessysla"
+IS,05,"Austur-Hunavatnssysla"
+IS,06,"Austur-Skaftafellssysla"
+IS,07,"Borgarfjardarsysla"
+IS,09,"Eyjafjardarsysla"
+IS,10,"Gullbringusysla"
+IS,15,"Kjosarsysla"
+IS,17,"Myrasysla"
+IS,20,"Nordur-Mulasysla"
+IS,21,"Nordur-Tingeyjarsysla"
+IS,23,"Rangarvallasysla"
+IS,28,"Skagafjardarsysla"
+IS,29,"Snafellsnes- og Hnappadalssysla"
+IS,31,"Sudur-Mulasysla"
+IS,32,"Sudur-Tingeyjarsysla"
+IS,34,"Vestur-Bardastrandarsysla"
+IS,35,"Vestur-Hunavatnssysla"
+IS,36,"Vestur-Isafjardarsysla"
+IS,37,"Vestur-Skaftafellssysla"
+IS,40,"Norourland Eystra"
+IS,41,"Norourland Vestra"
+IS,42,"Suourland"
+IS,43,"Suournes"
+IS,44,"Vestfiroir"
+IS,45,"Vesturland"
+IT,01,"Abruzzi"
+IT,02,"Basilicata"
+IT,03,"Calabria"
+IT,04,"Campania"
+IT,05,"Emilia-Romagna"
+IT,06,"Friuli-Venezia Giulia"
+IT,07,"Lazio"
+IT,08,"Liguria"
+IT,09,"Lombardia"
+IT,10,"Marche"
+IT,11,"Molise"
+IT,12,"Piemonte"
+IT,13,"Puglia"
+IT,14,"Sardegna"
+IT,15,"Sicilia"
+IT,16,"Toscana"
+IT,17,"Trentino-Alto Adige"
+IT,18,"Umbria"
+IT,19,"Valle d'Aosta"
+IT,20,"Veneto"
+JM,01,"Clarendon"
+JM,02,"Hanover"
+JM,04,"Manchester"
+JM,07,"Portland"
+JM,08,"Saint Andrew"
+JM,09,"Saint Ann"
+JM,10,"Saint Catherine"
+JM,11,"Saint Elizabeth"
+JM,12,"Saint James"
+JM,13,"Saint Mary"
+JM,14,"Saint Thomas"
+JM,15,"Trelawny"
+JM,16,"Westmoreland"
+JM,17,"Kingston"
+JO,02,"Al Balqa'"
+JO,07,"Ma"
+JO,09,"Al Karak"
+JO,10,"Al Mafraq"
+JO,11,"Amman Governorate"
+JO,12,"At Tafilah"
+JO,13,"Az Zarqa"
+JO,14,"Irbid"
+JO,16,"Amman"
+JP,01,"Aichi"
+JP,02,"Akita"
+JP,03,"Aomori"
+JP,04,"Chiba"
+JP,05,"Ehime"
+JP,06,"Fukui"
+JP,07,"Fukuoka"
+JP,08,"Fukushima"
+JP,09,"Gifu"
+JP,10,"Gumma"
+JP,11,"Hiroshima"
+JP,12,"Hokkaido"
+JP,13,"Hyogo"
+JP,14,"Ibaraki"
+JP,15,"Ishikawa"
+JP,16,"Iwate"
+JP,17,"Kagawa"
+JP,18,"Kagoshima"
+JP,19,"Kanagawa"
+JP,20,"Kochi"
+JP,21,"Kumamoto"
+JP,22,"Kyoto"
+JP,23,"Mie"
+JP,24,"Miyagi"
+JP,25,"Miyazaki"
+JP,26,"Nagano"
+JP,27,"Nagasaki"
+JP,28,"Nara"
+JP,29,"Niigata"
+JP,30,"Oita"
+JP,31,"Okayama"
+JP,32,"Osaka"
+JP,33,"Saga"
+JP,34,"Saitama"
+JP,35,"Shiga"
+JP,36,"Shimane"
+JP,37,"Shizuoka"
+JP,38,"Tochigi"
+JP,39,"Tokushima"
+JP,40,"Tokyo"
+JP,41,"Tottori"
+JP,42,"Toyama"
+JP,43,"Wakayama"
+JP,44,"Yamagata"
+JP,45,"Yamaguchi"
+JP,46,"Yamanashi"
+JP,47,"Okinawa"
+KE,01,"Central"
+KE,02,"Coast"
+KE,03,"Eastern"
+KE,05,"Nairobi Area"
+KE,06,"North-Eastern"
+KE,07,"Nyanza"
+KE,08,"Rift Valley"
+KE,09,"Western"
+KG,01,"Bishkek"
+KG,02,"Chuy"
+KG,03,"Jalal-Abad"
+KG,04,"Naryn"
+KG,05,"Osh"
+KG,06,"Talas"
+KG,07,"Ysyk-Kol"
+KG,08,"Osh"
+KG,09,"Batken"
+KH,02,"Kampong Cham"
+KH,03,"Kampong Chhnang"
+KH,04,"Kampong Spoe"
+KH,05,"Kampong Thum"
+KH,06,"Kampot"
+KH,07,"Kandal"
+KH,08,"Kaoh Kong"
+KH,09,"Kracheh"
+KH,10,"Mondol Kiri"
+KH,11,"Phnum Penh"
+KH,12,"Pouthisat"
+KH,13,"Preah Vihear"
+KH,14,"Prey Veng"
+KH,15,"Rotanokiri"
+KH,16,"Siemreab-Otdar Meanchey"
+KH,17,"Stoeng Treng"
+KH,18,"Svay Rieng"
+KH,19,"Takev"
+KH,29,"Batdambang"
+KH,30,"Pailin"
+KI,01,"Gilbert Islands"
+KI,02,"Line Islands"
+KI,03,"Phoenix Islands"
+KM,01,"Anjouan"
+KM,02,"Grande Comore"
+KM,03,"Moheli"
+KN,01,"Christ Church Nichola Town"
+KN,02,"Saint Anne Sandy Point"
+KN,03,"Saint George Basseterre"
+KN,04,"Saint George Gingerland"
+KN,05,"Saint James Windward"
+KN,06,"Saint John Capisterre"
+KN,07,"Saint John Figtree"
+KN,08,"Saint Mary Cayon"
+KN,09,"Saint Paul Capisterre"
+KN,10,"Saint Paul Charlestown"
+KN,11,"Saint Peter Basseterre"
+KN,12,"Saint Thomas Lowland"
+KN,13,"Saint Thomas Middle Island"
+KN,15,"Trinity Palmetto Point"
+KP,01,"Chagang-do"
+KP,03,"Hamgyong-namdo"
+KP,06,"Hwanghae-namdo"
+KP,07,"Hwanghae-bukto"
+KP,08,"Kaesong-si"
+KP,09,"Kangwon-do"
+KP,11,"P'yongan-bukto"
+KP,12,"P'yongyang-si"
+KP,13,"Yanggang-do"
+KP,14,"Namp'o-si"
+KP,15,"P'yongan-namdo"
+KP,17,"Hamgyong-bukto"
+KP,18,"Najin Sonbong-si"
+KR,01,"Cheju-do"
+KR,03,"Cholla-bukto"
+KR,05,"Ch'ungch'ong-bukto"
+KR,06,"Kangwon-do"
+KR,10,"Pusan-jikhalsi"
+KR,11,"Seoul-t'ukpyolsi"
+KR,12,"Inch'on-jikhalsi"
+KR,13,"Kyonggi-do"
+KR,14,"Kyongsang-bukto"
+KR,15,"Taegu-jikhalsi"
+KR,16,"Cholla-namdo"
+KR,17,"Ch'ungch'ong-namdo"
+KR,18,"Kwangju-jikhalsi"
+KR,19,"Taejon-jikhalsi"
+KR,20,"Kyongsang-namdo"
+KR,21,"Ulsan-gwangyoksi"
+KW,01,"Al Ahmadi"
+KW,02,"Al Kuwayt"
+KW,05,"Al Jahra"
+KW,07,"Al Farwaniyah"
+KW,08,"Hawalli"
+KW,09,"Mubarak al Kabir"
+KY,01,"Creek"
+KY,02,"Eastern"
+KY,03,"Midland"
+KY,04,"South Town"
+KY,05,"Spot Bay"
+KY,06,"Stake Bay"
+KY,07,"West End"
+KY,08,"Western"
+KZ,01,"Almaty"
+KZ,02,"Almaty City"
+KZ,03,"Aqmola"
+KZ,04,"Aqtobe"
+KZ,05,"Astana"
+KZ,06,"Atyrau"
+KZ,07,"West Kazakhstan"
+KZ,08,"Bayqonyr"
+KZ,09,"Mangghystau"
+KZ,10,"South Kazakhstan"
+KZ,11,"Pavlodar"
+KZ,12,"Qaraghandy"
+KZ,13,"Qostanay"
+KZ,14,"Qyzylorda"
+KZ,15,"East Kazakhstan"
+KZ,16,"North Kazakhstan"
+KZ,17,"Zhambyl"
+LA,01,"Attapu"
+LA,02,"Champasak"
+LA,03,"Houaphan"
+LA,04,"Khammouan"
+LA,05,"Louang Namtha"
+LA,07,"Oudomxai"
+LA,08,"Phongsali"
+LA,09,"Saravan"
+LA,10,"Savannakhet"
+LA,11,"Vientiane"
+LA,13,"Xaignabouri"
+LA,14,"Xiangkhoang"
+LA,17,"Louangphrabang"
+LB,01,"Beqaa"
+LB,03,"Liban-Nord"
+LB,04,"Beyrouth"
+LB,05,"Mont-Liban"
+LB,06,"Liban-Sud"
+LB,07,"Nabatiye"
+LB,08,"Beqaa"
+LB,09,"Liban-Nord"
+LB,10,"Aakk,r"
+LB,11,"Baalbek-Hermel"
+LC,01,"Anse-la-Raye"
+LC,02,"Dauphin"
+LC,03,"Castries"
+LC,04,"Choiseul"
+LC,05,"Dennery"
+LC,06,"Gros-Islet"
+LC,07,"Laborie"
+LC,08,"Micoud"
+LC,09,"Soufriere"
+LC,10,"Vieux-Fort"
+LC,11,"Praslin"
+LI,01,"Balzers"
+LI,02,"Eschen"
+LI,03,"Gamprin"
+LI,04,"Mauren"
+LI,05,"Planken"
+LI,06,"Ruggell"
+LI,07,"Schaan"
+LI,08,"Schellenberg"
+LI,09,"Triesen"
+LI,10,"Triesenberg"
+LI,11,"Vaduz"
+LI,21,"Gbarpolu"
+LI,22,"River Gee"
+LK,01,"Amparai"
+LK,02,"Anuradhapura"
+LK,03,"Badulla"
+LK,04,"Batticaloa"
+LK,06,"Galle"
+LK,07,"Hambantota"
+LK,09,"Kalutara"
+LK,10,"Kandy"
+LK,11,"Kegalla"
+LK,12,"Kurunegala"
+LK,14,"Matale"
+LK,15,"Matara"
+LK,16,"Moneragala"
+LK,17,"Nuwara Eliya"
+LK,18,"Polonnaruwa"
+LK,19,"Puttalam"
+LK,20,"Ratnapura"
+LK,21,"Trincomalee"
+LK,23,"Colombo"
+LK,24,"Gampaha"
+LK,25,"Jaffna"
+LK,26,"Mannar"
+LK,27,"Mullaittivu"
+LK,28,"Vavuniya"
+LK,29,"Central"
+LK,30,"North Central"
+LK,31,"Northern"
+LK,32,"North Western"
+LK,33,"Sabaragamuwa"
+LK,34,"Southern"
+LK,35,"Uva"
+LK,36,"Western"
+LR,01,"Bong"
+LR,04,"Grand Cape Mount"
+LR,06,"Maryland"
+LR,07,"Monrovia"
+LR,09,"Nimba"
+LR,10,"Sino"
+LR,11,"Grand Bassa"
+LR,14,"Montserrado"
+LR,19,"Grand Gedeh"
+LR,20,"Lofa"
+LS,10,"Berea"
+LS,11,"Butha-Buthe"
+LS,12,"Leribe"
+LS,13,"Mafeteng"
+LS,14,"Maseru"
+LS,15,"Mohales Hoek"
+LS,16,"Mokhotlong"
+LS,17,"Qachas Nek"
+LS,18,"Quthing"
+LS,19,"Thaba-Tseka"
+LT,56,"Alytaus Apskritis"
+LT,57,"Kauno Apskritis"
+LT,58,"Klaipedos Apskritis"
+LT,59,"Marijampoles Apskritis"
+LT,60,"Panevezio Apskritis"
+LT,61,"Siauliu Apskritis"
+LT,62,"Taurages Apskritis"
+LT,63,"Telsiu Apskritis"
+LT,64,"Utenos Apskritis"
+LT,65,"Vilniaus Apskritis"
+LU,01,"Diekirch"
+LU,02,"Grevenmacher"
+LU,03,"Luxembourg"
+LV,01,"Aizkraukles"
+LV,02,"Aluksnes"
+LV,03,"Balvu"
+LV,04,"Bauskas"
+LV,05,"Cesu"
+LV,06,"Daugavpils"
+LV,07,"Daugavpils"
+LV,08,"Dobeles"
+LV,09,"Gulbenes"
+LV,10,"Jekabpils"
+LV,11,"Jelgava"
+LV,12,"Jelgavas"
+LV,13,"Jurmala"
+LV,14,"Kraslavas"
+LV,15,"Kuldigas"
+LV,16,"Liepaja"
+LV,17,"Liepajas"
+LV,18,"Limbazu"
+LV,19,"Ludzas"
+LV,20,"Madonas"
+LV,21,"Ogres"
+LV,22,"Preilu"
+LV,23,"Rezekne"
+LV,24,"Rezeknes"
+LV,25,"Riga"
+LV,26,"Rigas"
+LV,27,"Saldus"
+LV,28,"Talsu"
+LV,29,"Tukuma"
+LV,30,"Valkas"
+LV,31,"Valmieras"
+LV,32,"Ventspils"
+LV,33,"Ventspils"
+LY,03,"Al Aziziyah"
+LY,05,"Al Jufrah"
+LY,08,"Al Kufrah"
+LY,13,"Ash Shati'"
+LY,30,"Murzuq"
+LY,34,"Sabha"
+LY,41,"Tarhunah"
+LY,42,"Tubruq"
+LY,45,"Zlitan"
+LY,47,"Ajdabiya"
+LY,48,"Al Fatih"
+LY,49,"Al Jabal al Akhdar"
+LY,50,"Al Khums"
+LY,51,"An Nuqat al Khams"
+LY,52,"Awbari"
+LY,53,"Az Zawiyah"
+LY,54,"Banghazi"
+LY,55,"Darnah"
+LY,56,"Ghadamis"
+LY,57,"Gharyan"
+LY,58,"Misratah"
+LY,59,"Sawfajjin"
+LY,60,"Surt"
+LY,61,"Tarabulus"
+LY,62,"Yafran"
+MA,01,"Agadir"
+MA,02,"Al Hoceima"
+MA,03,"Azilal"
+MA,04,"Ben Slimane"
+MA,05,"Beni Mellal"
+MA,06,"Boulemane"
+MA,07,"Casablanca"
+MA,08,"Chaouen"
+MA,09,"El Jadida"
+MA,10,"El Kelaa des Srarhna"
+MA,11,"Er Rachidia"
+MA,12,"Essaouira"
+MA,13,"Fes"
+MA,14,"Figuig"
+MA,15,"Kenitra"
+MA,16,"Khemisset"
+MA,17,"Khenifra"
+MA,18,"Khouribga"
+MA,19,"Marrakech"
+MA,20,"Meknes"
+MA,21,"Nador"
+MA,22,"Ouarzazate"
+MA,23,"Oujda"
+MA,24,"Rabat-Sale"
+MA,25,"Safi"
+MA,26,"Settat"
+MA,27,"Tanger"
+MA,29,"Tata"
+MA,30,"Taza"
+MA,32,"Tiznit"
+MA,33,"Guelmim"
+MA,34,"Ifrane"
+MA,35,"Laayoune"
+MA,36,"Tan-Tan"
+MA,37,"Taounate"
+MA,38,"Sidi Kacem"
+MA,39,"Taroudannt"
+MA,40,"Tetouan"
+MA,41,"Larache"
+MA,45,"Grand Casablanca"
+MA,46,"Fes-Boulemane"
+MA,47,"Marrakech-Tensift-Al Haouz"
+MA,48,"Meknes-Tafilalet"
+MA,49,"Rabat-Sale-Zemmour-Zaer"
+MA,50,"Chaouia-Ouardigha"
+MA,51,"Doukkala-Abda"
+MA,52,"Gharb-Chrarda-Beni Hssen"
+MA,53,"Guelmim-Es Smara"
+MA,54,"Oriental"
+MA,55,"Souss-Massa-Dr,a"
+MA,56,"Tadla-Azilal"
+MA,57,"Tanger-Tetouan"
+MA,58,"Taza-Al Hoceima-Taounate"
+MA,59,"La,youne-Boujdour-Sakia El Hamra"
+MC,01,"La Condamine"
+MC,02,"Monaco"
+MC,03,"Monte-Carlo"
+MD,46,"Balti"
+MD,47,"Cahul"
+MD,48,"Chisinau"
+MD,49,"Stinga Nistrului"
+MD,50,"Edinet"
+MD,51,"Gagauzia"
+MD,52,"Lapusna"
+MD,53,"Orhei"
+MD,54,"Soroca"
+MD,55,"Tighina"
+MD,56,"Ungheni"
+MD,58,"Stinga Nistrului"
+MD,59,"Anenii Noi"
+MD,60,"Balti"
+MD,61,"Basarabeasca"
+MD,62,"Bender"
+MD,63,"Briceni"
+MD,64,"Cahul"
+MD,65,"Cantemir"
+MD,66,"Calarasi"
+MD,67,"Causeni"
+MD,68,"Cimislia"
+MD,69,"Criuleni"
+MD,70,"Donduseni"
+MD,71,"Drochia"
+MD,72,"Dubasari"
+MD,73,"Edinet"
+MD,74,"Falesti"
+MD,75,"Floresti"
+MD,76,"Glodeni"
+MD,77,"Hincesti"
+MD,78,"Ialoveni"
+MD,79,"Leova"
+MD,80,"Nisporeni"
+MD,81,"Ocnita"
+MD,83,"Rezina"
+MD,84,"Riscani"
+MD,85,"Singerei"
+MD,86,"Soldanesti"
+MD,87,"Soroca"
+MD,88,"Stefan-Voda"
+MD,89,"Straseni"
+MD,90,"Taraclia"
+MD,91,"Telenesti"
+MD,92,"Ungheni"
+MG,01,"Antsiranana"
+MG,02,"Fianarantsoa"
+MG,03,"Mahajanga"
+MG,04,"Toamasina"
+MG,05,"Antananarivo"
+MG,06,"Toliara"
+MK,01,"Aracinovo"
+MK,02,"Bac"
+MK,03,"Belcista"
+MK,04,"Berovo"
+MK,05,"Bistrica"
+MK,06,"Bitola"
+MK,07,"Blatec"
+MK,08,"Bogdanci"
+MK,09,"Bogomila"
+MK,10,"Bogovinje"
+MK,11,"Bosilovo"
+MK,12,"Brvenica"
+MK,13,"Cair"
+MK,14,"Capari"
+MK,15,"Caska"
+MK,16,"Cegrane"
+MK,17,"Centar"
+MK,18,"Centar Zupa"
+MK,19,"Cesinovo"
+MK,20,"Cucer-Sandevo"
+MK,21,"Debar"
+MK,22,"Delcevo"
+MK,23,"Delogozdi"
+MK,24,"Demir Hisar"
+MK,25,"Demir Kapija"
+MK,26,"Dobrusevo"
+MK,27,"Dolna Banjica"
+MK,28,"Dolneni"
+MK,29,"Dorce Petrov"
+MK,30,"Drugovo"
+MK,31,"Dzepciste"
+MK,32,"Gazi Baba"
+MK,33,"Gevgelija"
+MK,34,"Gostivar"
+MK,35,"Gradsko"
+MK,36,"Ilinden"
+MK,37,"Izvor"
+MK,38,"Jegunovce"
+MK,39,"Kamenjane"
+MK,40,"Karbinci"
+MK,41,"Karpos"
+MK,42,"Kavadarci"
+MK,43,"Kicevo"
+MK,44,"Kisela Voda"
+MK,45,"Klecevce"
+MK,46,"Kocani"
+MK,47,"Konce"
+MK,48,"Kondovo"
+MK,49,"Konopiste"
+MK,50,"Kosel"
+MK,51,"Kratovo"
+MK,52,"Kriva Palanka"
+MK,53,"Krivogastani"
+MK,54,"Krusevo"
+MK,55,"Kuklis"
+MK,56,"Kukurecani"
+MK,57,"Kumanovo"
+MK,58,"Labunista"
+MK,59,"Lipkovo"
+MK,60,"Lozovo"
+MK,61,"Lukovo"
+MK,62,"Makedonska Kamenica"
+MK,63,"Makedonski Brod"
+MK,64,"Mavrovi Anovi"
+MK,65,"Meseista"
+MK,66,"Miravci"
+MK,67,"Mogila"
+MK,68,"Murtino"
+MK,69,"Negotino"
+MK,70,"Negotino-Polosko"
+MK,71,"Novaci"
+MK,72,"Novo Selo"
+MK,73,"Oblesevo"
+MK,74,"Ohrid"
+MK,75,"Orasac"
+MK,76,"Orizari"
+MK,77,"Oslomej"
+MK,78,"Pehcevo"
+MK,79,"Petrovec"
+MK,80,"Plasnica"
+MK,81,"Podares"
+MK,82,"Prilep"
+MK,83,"Probistip"
+MK,84,"Radovis"
+MK,85,"Rankovce"
+MK,86,"Resen"
+MK,87,"Rosoman"
+MK,88,"Rostusa"
+MK,89,"Samokov"
+MK,90,"Saraj"
+MK,91,"Sipkovica"
+MK,92,"Sopiste"
+MK,93,"Sopotnica"
+MK,94,"Srbinovo"
+MK,95,"Staravina"
+MK,96,"Star Dojran"
+MK,97,"Staro Nagoricane"
+MK,98,"Stip"
+MK,99,"Struga"
+MK,A1,"Strumica"
+MK,A2,"Studenicani"
+MK,A3,"Suto Orizari"
+MK,A4,"Sveti Nikole"
+MK,A5,"Tearce"
+MK,A6,"Tetovo"
+MK,A7,"Topolcani"
+MK,A8,"Valandovo"
+MK,A9,"Vasilevo"
+MK,B1,"Veles"
+MK,B2,"Velesta"
+MK,B3,"Vevcani"
+MK,B4,"Vinica"
+MK,B5,"Vitoliste"
+MK,B6,"Vranestica"
+MK,B7,"Vrapciste"
+MK,B8,"Vratnica"
+MK,B9,"Vrutok"
+MK,C1,"Zajas"
+MK,C2,"Zelenikovo"
+MK,C3,"Zelino"
+MK,C4,"Zitose"
+MK,C5,"Zletovo"
+MK,C6,"Zrnovci"
+ML,01,"Bamako"
+ML,03,"Kayes"
+ML,04,"Mopti"
+ML,05,"Segou"
+ML,06,"Sikasso"
+ML,07,"Koulikoro"
+ML,08,"Tombouctou"
+ML,09,"Gao"
+ML,10,"Kidal"
+MM,01,"Rakhine State"
+MM,02,"Chin State"
+MM,03,"Irrawaddy"
+MM,04,"Kachin State"
+MM,05,"Karan State"
+MM,06,"Kayah State"
+MM,07,"Magwe"
+MM,08,"Mandalay"
+MM,09,"Pegu"
+MM,10,"Sagaing"
+MM,11,"Shan State"
+MM,12,"Tenasserim"
+MM,13,"Mon State"
+MM,14,"Rangoon"
+MM,17,"Yangon"
+MN,01,"Arhangay"
+MN,02,"Bayanhongor"
+MN,03,"Bayan-Olgiy"
+MN,05,"Darhan"
+MN,06,"Dornod"
+MN,07,"Dornogovi"
+MN,08,"Dundgovi"
+MN,09,"Dzavhan"
+MN,10,"Govi-Altay"
+MN,11,"Hentiy"
+MN,12,"Hovd"
+MN,13,"Hovsgol"
+MN,14,"Omnogovi"
+MN,15,"Ovorhangay"
+MN,16,"Selenge"
+MN,17,"Suhbaatar"
+MN,18,"Tov"
+MN,19,"Uvs"
+MN,20,"Ulaanbaatar"
+MN,21,"Bulgan"
+MN,22,"Erdenet"
+MN,23,"Darhan-Uul"
+MN,24,"Govisumber"
+MN,25,"Orhon"
+MO,01,"Ilhas"
+MO,02,"Macau"
+MR,01,"Hodh Ech Chargui"
+MR,02,"Hodh El Gharbi"
+MR,03,"Assaba"
+MR,04,"Gorgol"
+MR,05,"Brakna"
+MR,06,"Trarza"
+MR,07,"Adrar"
+MR,08,"Dakhlet Nouadhibou"
+MR,09,"Tagant"
+MR,10,"Guidimaka"
+MR,11,"Tiris Zemmour"
+MR,12,"Inchiri"
+MS,01,"Saint Anthony"
+MS,02,"Saint Georges"
+MS,03,"Saint Peter"
+MU,12,"Black River"
+MU,13,"Flacq"
+MU,14,"Grand Port"
+MU,15,"Moka"
+MU,16,"Pamplemousses"
+MU,17,"Plaines Wilhems"
+MU,18,"Port Louis"
+MU,19,"Riviere du Rempart"
+MU,20,"Savanne"
+MU,21,"Agalega Islands"
+MU,22,"Cargados Carajos"
+MU,23,"Rodrigues"
+MV,01,"Seenu"
+MV,02,"Aliff"
+MV,03,"Laviyani"
+MV,04,"Waavu"
+MV,05,"Laamu"
+MV,07,"Haa Aliff"
+MV,08,"Thaa"
+MV,12,"Meemu"
+MV,13,"Raa"
+MV,14,"Faafu"
+MV,17,"Daalu"
+MV,20,"Baa"
+MV,23,"Haa Daalu"
+MV,24,"Shaviyani"
+MV,25,"Noonu"
+MV,26,"Kaafu"
+MV,27,"Gaafu Aliff"
+MV,28,"Gaafu Daalu"
+MV,29,"Naviyani"
+MV,40,"Male"
+MW,02,"Chikwawa"
+MW,03,"Chiradzulu"
+MW,04,"Chitipa"
+MW,05,"Thyolo"
+MW,06,"Dedza"
+MW,07,"Dowa"
+MW,08,"Karonga"
+MW,09,"Kasungu"
+MW,11,"Lilongwe"
+MW,12,"Mangochi"
+MW,13,"Mchinji"
+MW,15,"Mzimba"
+MW,16,"Ntcheu"
+MW,17,"Nkhata Bay"
+MW,18,"Nkhotakota"
+MW,19,"Nsanje"
+MW,20,"Ntchisi"
+MW,21,"Rumphi"
+MW,22,"Salima"
+MW,23,"Zomba"
+MW,24,"Blantyre"
+MW,25,"Mwanza"
+MW,26,"Balaka"
+MW,27,"Likoma"
+MW,28,"Machinga"
+MW,29,"Mulanje"
+MW,30,"Phalombe"
+MX,01,"Aguascalientes"
+MX,02,"Baja California"
+MX,03,"Baja California Sur"
+MX,04,"Campeche"
+MX,05,"Chiapas"
+MX,06,"Chihuahua"
+MX,07,"Coahuila de Zaragoza"
+MX,08,"Colima"
+MX,09,"Distrito Federal"
+MX,10,"Durango"
+MX,11,"Guanajuato"
+MX,12,"Guerrero"
+MX,13,"Hidalgo"
+MX,14,"Jalisco"
+MX,15,"Mexico"
+MX,16,"Michoacan de Ocampo"
+MX,17,"Morelos"
+MX,18,"Nayarit"
+MX,19,"Nuevo Leon"
+MX,20,"Oaxaca"
+MX,21,"Puebla"
+MX,22,"Queretaro de Arteaga"
+MX,23,"Quintana Roo"
+MX,24,"San Luis Potosi"
+MX,25,"Sinaloa"
+MX,26,"Sonora"
+MX,27,"Tabasco"
+MX,28,"Tamaulipas"
+MX,29,"Tlaxcala"
+MX,30,"Veracruz-Llave"
+MX,31,"Yucatan"
+MX,32,"Zacatecas"
+MY,01,"Johor"
+MY,02,"Kedah"
+MY,03,"Kelantan"
+MY,04,"Melaka"
+MY,05,"Negeri Sembilan"
+MY,06,"Pahang"
+MY,07,"Perak"
+MY,08,"Perlis"
+MY,09,"Pulau Pinang"
+MY,11,"Sarawak"
+MY,12,"Selangor"
+MY,13,"Terengganu"
+MY,14,"Kuala Lumpur"
+MY,15,"Labuan"
+MY,16,"Sabah"
+MY,17,"Putrajaya"
+MZ,01,"Cabo Delgado"
+MZ,02,"Gaza"
+MZ,03,"Inhambane"
+MZ,04,"Maputo"
+MZ,05,"Sofala"
+MZ,06,"Nampula"
+MZ,07,"Niassa"
+MZ,08,"Tete"
+MZ,09,"Zambezia"
+MZ,10,"Manica"
+MZ,11,"Maputo"
+NA,01,"Bethanien"
+NA,02,"Caprivi Oos"
+NA,03,"Boesmanland"
+NA,04,"Gobabis"
+NA,05,"Grootfontein"
+NA,06,"Kaokoland"
+NA,07,"Karibib"
+NA,08,"Keetmanshoop"
+NA,09,"Luderitz"
+NA,10,"Maltahohe"
+NA,11,"Okahandja"
+NA,12,"Omaruru"
+NA,13,"Otjiwarongo"
+NA,14,"Outjo"
+NA,15,"Owambo"
+NA,16,"Rehoboth"
+NA,17,"Swakopmund"
+NA,18,"Tsumeb"
+NA,20,"Karasburg"
+NA,21,"Windhoek"
+NA,22,"Damaraland"
+NA,23,"Hereroland Oos"
+NA,24,"Hereroland Wes"
+NA,25,"Kavango"
+NA,26,"Mariental"
+NA,27,"Namaland"
+NA,28,"Caprivi"
+NA,29,"Erongo"
+NA,30,"Hardap"
+NA,31,"Karas"
+NA,32,"Kunene"
+NA,33,"Ohangwena"
+NA,34,"Okavango"
+NA,35,"Omaheke"
+NA,36,"Omusati"
+NA,37,"Oshana"
+NA,38,"Oshikoto"
+NA,39,"Otjozondjupa"
+NE,01,"Agadez"
+NE,02,"Diffa"
+NE,03,"Dosso"
+NE,04,"Maradi"
+NE,05,"Niamey"
+NE,06,"Tahoua"
+NE,07,"Zinder"
+NE,08,"Niamey"
+NG,05,"Lagos"
+NG,10,"Rivers"
+NG,11,"Federal Capital Territory"
+NG,16,"Ogun"
+NG,17,"Ondo"
+NG,21,"Akwa Ibom"
+NG,22,"Cross River"
+NG,23,"Kaduna"
+NG,24,"Katsina"
+NG,25,"Anambra"
+NG,26,"Benue"
+NG,27,"Borno"
+NG,28,"Imo"
+NG,29,"Kano"
+NG,30,"Kwara"
+NG,31,"Niger"
+NG,32,"Oyo"
+NG,35,"Adamawa"
+NG,36,"Delta"
+NG,37,"Edo"
+NG,39,"Jigawa"
+NG,40,"Kebbi"
+NG,41,"Kogi"
+NG,42,"Osun"
+NG,43,"Taraba"
+NG,44,"Yobe"
+NG,45,"Abia"
+NG,46,"Bauchi"
+NG,47,"Enugu"
+NG,48,"Ondo"
+NG,49,"Plateau"
+NG,50,"Rivers"
+NG,51,"Sokoto"
+NG,52,"Bayelsa"
+NG,53,"Ebonyi"
+NG,54,"Ekiti"
+NG,55,"Gombe"
+NG,56,"Nassarawa"
+NG,57,"Zamfara"
+NI,01,"Boaco"
+NI,02,"Carazo"
+NI,03,"Chinandega"
+NI,04,"Chontales"
+NI,05,"Esteli"
+NI,06,"Granada"
+NI,07,"Jinotega"
+NI,08,"Leon"
+NI,09,"Madriz"
+NI,10,"Managua"
+NI,11,"Masaya"
+NI,12,"Matagalpa"
+NI,13,"Nueva Segovia"
+NI,14,"Rio San Juan"
+NI,15,"Rivas"
+NI,16,"Zelaya"
+NL,01,"Drenthe"
+NL,02,"Friesland"
+NL,03,"Gelderland"
+NL,04,"Groningen"
+NL,05,"Limburg"
+NL,06,"Noord-Brabant"
+NL,07,"Noord-Holland"
+NL,08,"Overijssel"
+NL,09,"Utrecht"
+NL,10,"Zeeland"
+NL,11,"Zuid-Holland"
+NL,12,"Dronten"
+NL,13,"Zuidelijke IJsselmeerpolders"
+NL,14,"Lelystad"
+NL,15,"Overijssel"
+NL,16,"Flevoland"
+NO,01,"Akershus"
+NO,02,"Aust-Agder"
+NO,04,"Buskerud"
+NO,05,"Finnmark"
+NO,06,"Hedmark"
+NO,07,"Hordaland"
+NO,08,"More og Romsdal"
+NO,09,"Nordland"
+NO,10,"Nord-Trondelag"
+NO,11,"Oppland"
+NO,12,"Oslo"
+NO,13,"Ostfold"
+NO,14,"Rogaland"
+NO,15,"Sogn og Fjordane"
+NO,16,"Sor-Trondelag"
+NO,17,"Telemark"
+NO,18,"Troms"
+NO,19,"Vest-Agder"
+NO,20,"Vestfold"
+NP,01,"Bagmati"
+NP,02,"Bheri"
+NP,03,"Dhawalagiri"
+NP,04,"Gandaki"
+NP,05,"Janakpur"
+NP,06,"Karnali"
+NP,07,"Kosi"
+NP,08,"Lumbini"
+NP,09,"Mahakali"
+NP,10,"Mechi"
+NP,11,"Narayani"
+NP,12,"Rapti"
+NP,13,"Sagarmatha"
+NP,14,"Seti"
+NR,01,"Aiwo"
+NR,02,"Anabar"
+NR,03,"Anetan"
+NR,04,"Anibare"
+NR,05,"Baiti"
+NR,06,"Boe"
+NR,07,"Buada"
+NR,08,"Denigomodu"
+NR,09,"Ewa"
+NR,10,"Ijuw"
+NR,11,"Meneng"
+NR,12,"Nibok"
+NR,13,"Uaboe"
+NR,14,"Yaren"
+NZ,10,"Chatham Islands"
+NZ,E7,"Auckland"
+NZ,E8,"Bay of Plenty"
+NZ,E9,"Canterbury"
+NZ,F1,"Gisborne"
+NZ,F2,"Hawke's Bay"
+NZ,F3,"Manawatu-Wanganui"
+NZ,F4,"Marlborough"
+NZ,F5,"Nelson"
+NZ,F6,"Northland"
+NZ,F7,"Otago"
+NZ,F8,"Southland"
+NZ,F9,"Taranaki"
+NZ,G1,"Waikato"
+NZ,G2,"Wellington"
+NZ,G3,"West Coast"
+OM,01,"Ad Dakhiliyah"
+OM,02,"Al Batinah"
+OM,03,"Al Wusta"
+OM,04,"Ash Sharqiyah"
+OM,05,"Az Zahirah"
+OM,06,"Masqat"
+OM,07,"Musandam"
+OM,08,"Zufar"
+PA,01,"Bocas del Toro"
+PA,02,"Chiriqui"
+PA,03,"Cocle"
+PA,04,"Colon"
+PA,05,"Darien"
+PA,06,"Herrera"
+PA,07,"Los Santos"
+PA,08,"Panama"
+PA,09,"San Blas"
+PA,10,"Veraguas"
+PE,01,"Amazonas"
+PE,02,"Ancash"
+PE,03,"Apurimac"
+PE,04,"Arequipa"
+PE,05,"Ayacucho"
+PE,06,"Cajamarca"
+PE,07,"Callao"
+PE,08,"Cusco"
+PE,09,"Huancavelica"
+PE,10,"Huanuco"
+PE,11,"Ica"
+PE,12,"Junin"
+PE,13,"La Libertad"
+PE,14,"Lambayeque"
+PE,15,"Lima"
+PE,16,"Loreto"
+PE,17,"Madre de Dios"
+PE,18,"Moquegua"
+PE,19,"Pasco"
+PE,20,"Piura"
+PE,21,"Puno"
+PE,22,"San Martin"
+PE,23,"Tacna"
+PE,24,"Tumbes"
+PE,25,"Ucayali"
+PG,01,"Central"
+PG,02,"Gulf"
+PG,03,"Milne Bay"
+PG,04,"Northern"
+PG,05,"Southern Highlands"
+PG,06,"Western"
+PG,07,"North Solomons"
+PG,08,"Chimbu"
+PG,09,"Eastern Highlands"
+PG,10,"East New Britain"
+PG,11,"East Sepik"
+PG,12,"Madang"
+PG,13,"Manus"
+PG,14,"Morobe"
+PG,15,"New Ireland"
+PG,16,"Western Highlands"
+PG,17,"West New Britain"
+PG,18,"Sandaun"
+PG,19,"Enga"
+PG,20,"National Capital"
+PH,01,"Abra"
+PH,02,"Agusan del Norte"
+PH,03,"Agusan del Sur"
+PH,04,"Aklan"
+PH,05,"Albay"
+PH,06,"Antique"
+PH,07,"Bataan"
+PH,08,"Batanes"
+PH,09,"Batangas"
+PH,10,"Benguet"
+PH,11,"Bohol"
+PH,12,"Bukidnon"
+PH,13,"Bulacan"
+PH,14,"Cagayan"
+PH,15,"Camarines Norte"
+PH,16,"Camarines Sur"
+PH,17,"Camiguin"
+PH,18,"Capiz"
+PH,19,"Catanduanes"
+PH,20,"Cavite"
+PH,21,"Cebu"
+PH,22,"Basilan"
+PH,23,"Eastern Samar"
+PH,24,"Davao"
+PH,25,"Davao del Sur"
+PH,26,"Davao Oriental"
+PH,27,"Ifugao"
+PH,28,"Ilocos Norte"
+PH,29,"Ilocos Sur"
+PH,30,"Iloilo"
+PH,31,"Isabela"
+PH,32,"Kalinga-Apayao"
+PH,33,"Laguna"
+PH,34,"Lanao del Norte"
+PH,35,"Lanao del Sur"
+PH,36,"La Union"
+PH,37,"Leyte"
+PH,38,"Marinduque"
+PH,39,"Masbate"
+PH,40,"Mindoro Occidental"
+PH,41,"Mindoro Oriental"
+PH,42,"Misamis Occidental"
+PH,43,"Misamis Oriental"
+PH,44,"Mountain"
+PH,46,"Negros Oriental"
+PH,47,"Nueva Ecija"
+PH,48,"Nueva Vizcaya"
+PH,49,"Palawan"
+PH,50,"Pampanga"
+PH,51,"Pangasinan"
+PH,53,"Rizal"
+PH,54,"Romblon"
+PH,55,"Samar"
+PH,56,"Maguindanao"
+PH,57,"North Cotabato"
+PH,58,"Sorsogon"
+PH,59,"Southern Leyte"
+PH,60,"Sulu"
+PH,61,"Surigao del Norte"
+PH,62,"Surigao del Sur"
+PH,63,"Tarlac"
+PH,64,"Zambales"
+PH,65,"Zamboanga del Norte"
+PH,66,"Zamboanga del Sur"
+PH,67,"Northern Samar"
+PH,68,"Quirino"
+PH,69,"Siquijor"
+PH,70,"South Cotabato"
+PH,71,"Sultan Kudarat"
+PH,72,"Tawitawi"
+PH,A1,"Angeles"
+PH,A2,"Bacolod"
+PH,A3,"Bago"
+PH,A4,"Baguio"
+PH,A5,"Bais"
+PH,A6,"Basilan City"
+PH,A7,"Batangas City"
+PH,A8,"Butuan"
+PH,A9,"Cabanatuan"
+PH,B1,"Cadiz"
+PH,B2,"Cagayan de Oro"
+PH,B3,"Calbayog"
+PH,B4,"Caloocan"
+PH,B5,"Canlaon"
+PH,B6,"Cavite City"
+PH,B7,"Cebu City"
+PH,B8,"Cotabato"
+PH,B9,"Dagupan"
+PH,C1,"Danao"
+PH,C2,"Dapitan"
+PH,C3,"Davao City"
+PH,C4,"Dipolog"
+PH,C5,"Dumaguete"
+PH,C6,"General Santos"
+PH,C7,"Gingoog"
+PH,C8,"Iligan"
+PH,C9,"Iloilo City"
+PH,D1,"Iriga"
+PH,D2,"La Carlota"
+PH,D3,"Laoag"
+PH,D4,"Lapu-Lapu"
+PH,D5,"Legaspi"
+PH,D6,"Lipa"
+PH,D7,"Lucena"
+PH,D8,"Mandaue"
+PH,D9,"Manila"
+PH,E1,"Marawi"
+PH,E2,"Naga"
+PH,E3,"Olongapo"
+PH,E4,"Ormoc"
+PH,E5,"Oroquieta"
+PH,E6,"Ozamis"
+PH,E7,"Pagadian"
+PH,E8,"Palayan"
+PH,E9,"Pasay"
+PH,F1,"Puerto Princesa"
+PH,F2,"Quezon City"
+PH,F3,"Roxas"
+PH,F4,"San Carlos"
+PH,F5,"San Carlos"
+PH,F6,"San Jose"
+PH,F7,"San Pablo"
+PH,F8,"Silay"
+PH,F9,"Surigao"
+PH,G1,"Tacloban"
+PH,G2,"Tagaytay"
+PH,G3,"Tagbilaran"
+PH,G4,"Tangub"
+PH,G5,"Toledo"
+PH,G6,"Trece Martires"
+PH,G7,"Zamboanga"
+PH,G8,"Aurora"
+PH,H2,"Quezon"
+PH,H3,"Negros Occidental"
+PK,01,"Federally Administered Tribal Areas"
+PK,02,"Balochistan"
+PK,03,"North-West Frontier"
+PK,04,"Punjab"
+PK,05,"Sindh"
+PK,06,"Azad Kashmir"
+PK,07,"Northern Areas"
+PK,08,"Islamabad"
+PL,23,"Biala Podlaska"
+PL,24,"Bialystok"
+PL,25,"Bielsko"
+PL,26,"Bydgoszcz"
+PL,27,"Chelm"
+PL,28,"Ciechanow"
+PL,29,"Czestochowa"
+PL,30,"Elblag"
+PL,31,"Gdansk"
+PL,32,"Gorzow"
+PL,33,"Jelenia Gora"
+PL,34,"Kalisz"
+PL,35,"Katowice"
+PL,36,"Kielce"
+PL,37,"Konin"
+PL,38,"Koszalin"
+PL,39,"Krakow"
+PL,40,"Krosno"
+PL,41,"Legnica"
+PL,42,"Leszno"
+PL,43,"Lodz"
+PL,44,"Lomza"
+PL,45,"Lublin"
+PL,46,"Nowy Sacz"
+PL,47,"Olsztyn"
+PL,48,"Opole"
+PL,49,"Ostroleka"
+PL,50,"Pila"
+PL,51,"Piotrkow"
+PL,52,"Plock"
+PL,53,"Poznan"
+PL,54,"Przemysl"
+PL,55,"Radom"
+PL,56,"Rzeszow"
+PL,57,"Siedlce"
+PL,58,"Sieradz"
+PL,59,"Skierniewice"
+PL,60,"Slupsk"
+PL,61,"Suwalki"
+PL,62,"Szczecin"
+PL,63,"Tarnobrzeg"
+PL,64,"Tarnow"
+PL,65,"Torun"
+PL,66,"Walbrzych"
+PL,67,"Warszawa"
+PL,68,"Wloclawek"
+PL,69,"Wroclaw"
+PL,70,"Zamosc"
+PL,71,"Zielona Gora"
+PL,72,"Dolnoslaskie"
+PL,73,"Kujawsko-Pomorskie"
+PL,74,"Lodzkie"
+PL,75,"Lubelskie"
+PL,76,"Lubuskie"
+PL,77,"Malopolskie"
+PL,78,"Mazowieckie"
+PL,79,"Opolskie"
+PL,80,"Podkarpackie"
+PL,81,"Podlaskie"
+PL,82,"Pomorskie"
+PL,83,"Slaskie"
+PL,84,"Swietokrzyskie"
+PL,85,"Warminsko-Mazurskie"
+PL,86,"Wielkopolskie"
+PL,87,"Zachodniopomorskie"
+PS,GZ,"Gaza"
+PS,WE,"West Bank"
+PT,02,"Aveiro"
+PT,03,"Beja"
+PT,04,"Braga"
+PT,05,"Braganca"
+PT,06,"Castelo Branco"
+PT,07,"Coimbra"
+PT,08,"Evora"
+PT,09,"Faro"
+PT,10,"Madeira"
+PT,11,"Guarda"
+PT,13,"Leiria"
+PT,14,"Lisboa"
+PT,16,"Portalegre"
+PT,17,"Porto"
+PT,18,"Santarem"
+PT,19,"Setubal"
+PT,20,"Viana do Castelo"
+PT,21,"Vila Real"
+PT,22,"Viseu"
+PT,23,"Azores"
+PY,01,"Alto Parana"
+PY,02,"Amambay"
+PY,03,"Boqueron"
+PY,04,"Caaguazu"
+PY,05,"Caazapa"
+PY,06,"Central"
+PY,07,"Concepcion"
+PY,08,"Cordillera"
+PY,10,"Guaira"
+PY,11,"Itapua"
+PY,12,"Misiones"
+PY,13,"Neembucu"
+PY,15,"Paraguari"
+PY,16,"Presidente Hayes"
+PY,17,"San Pedro"
+PY,19,"Canindeyu"
+PY,20,"Chaco"
+PY,21,"Nueva Asuncion"
+PY,23,"Alto Paraguay"
+QA,01,"Ad Dawhah"
+QA,02,"Al Ghuwariyah"
+QA,03,"Al Jumaliyah"
+QA,04,"Al Khawr"
+QA,05,"Al Wakrah Municipality"
+QA,06,"Ar Rayyan"
+QA,08,"Madinat ach Shamal"
+QA,09,"Umm Salal"
+QA,10,"Al Wakrah"
+QA,11,"Jariyan al Batnah"
+QA,12,"Umm Sa'id"
+RO,01,"Alba"
+RO,02,"Arad"
+RO,03,"Arges"
+RO,04,"Bacau"
+RO,05,"Bihor"
+RO,06,"Bistrita-Nasaud"
+RO,07,"Botosani"
+RO,08,"Braila"
+RO,09,"Brasov"
+RO,10,"Bucuresti"
+RO,11,"Buzau"
+RO,12,"Caras-Severin"
+RO,13,"Cluj"
+RO,14,"Constanta"
+RO,15,"Covasna"
+RO,16,"Dambovita"
+RO,17,"Dolj"
+RO,18,"Galati"
+RO,19,"Gorj"
+RO,20,"Harghita"
+RO,21,"Hunedoara"
+RO,22,"Ialomita"
+RO,23,"Iasi"
+RO,25,"Maramures"
+RO,26,"Mehedinti"
+RO,27,"Mures"
+RO,28,"Neamt"
+RO,29,"Olt"
+RO,30,"Prahova"
+RO,31,"Salaj"
+RO,32,"Satu Mare"
+RO,33,"Sibiu"
+RO,34,"Suceava"
+RO,35,"Teleorman"
+RO,36,"Timis"
+RO,37,"Tulcea"
+RO,38,"Vaslui"
+RO,39,"Valcea"
+RO,40,"Vrancea"
+RO,41,"Calarasi"
+RO,42,"Giurgiu"
+RO,43,"Ilfov"
+RS,00,"Serbia proper"
+RS,01,"Kosovo"
+RS,02,"Vojvodina"
+RU,01,"Adygeya, Republic of"
+RU,02,"Aginsky Buryatsky AO"
+RU,03,"Gorno-Altay"
+RU,04,"Altaisky krai"
+RU,05,"Amur"
+RU,06,"Arkhangel'sk"
+RU,07,"Astrakhan'"
+RU,08,"Bashkortostan"
+RU,09,"Belgorod"
+RU,10,"Bryansk"
+RU,11,"Buryat"
+RU,12,"Chechnya"
+RU,13,"Chelyabinsk"
+RU,14,"Chita"
+RU,15,"Chukot"
+RU,16,"Chuvashia"
+RU,17,"Dagestan"
+RU,18,"Evenk"
+RU,19,"Ingush"
+RU,20,"Irkutsk"
+RU,21,"Ivanovo"
+RU,22,"Kabardin-Balkar"
+RU,23,"Kaliningrad"
+RU,24,"Kalmyk"
+RU,25,"Kaluga"
+RU,26,"Kamchatka"
+RU,27,"Karachay-Cherkess"
+RU,28,"Karelia"
+RU,29,"Kemerovo"
+RU,30,"Khabarovsk"
+RU,31,"Khakass"
+RU,32,"Khanty-Mansiy"
+RU,33,"Kirov"
+RU,34,"Komi"
+RU,35,"Komi-Permyak"
+RU,36,"Koryak"
+RU,37,"Kostroma"
+RU,38,"Krasnodar"
+RU,39,"Krasnoyarsk"
+RU,40,"Kurgan"
+RU,41,"Kursk"
+RU,42,"Leningrad"
+RU,43,"Lipetsk"
+RU,44,"Magadan"
+RU,45,"Mariy-El"
+RU,46,"Mordovia"
+RU,47,"Moskva"
+RU,48,"Moscow City"
+RU,49,"Murmansk"
+RU,50,"Nenets"
+RU,51,"Nizhegorod"
+RU,52,"Novgorod"
+RU,53,"Novosibirsk"
+RU,54,"Omsk"
+RU,55,"Orenburg"
+RU,56,"Orel"
+RU,57,"Penza"
+RU,58,"Perm'"
+RU,59,"Primor'ye"
+RU,60,"Pskov"
+RU,61,"Rostov"
+RU,62,"Ryazan'"
+RU,63,"Sakha"
+RU,64,"Sakhalin"
+RU,65,"Samara"
+RU,66,"Saint Petersburg City"
+RU,67,"Saratov"
+RU,68,"North Ossetia"
+RU,69,"Smolensk"
+RU,70,"Stavropol'"
+RU,71,"Sverdlovsk"
+RU,72,"Tambovskaya oblast"
+RU,73,"Tatarstan"
+RU,74,"Taymyr"
+RU,75,"Tomsk"
+RU,76,"Tula"
+RU,77,"Tver'"
+RU,78,"Tyumen'"
+RU,79,"Tuva"
+RU,80,"Udmurt"
+RU,81,"Ul'yanovsk"
+RU,82,"Ust-Orda Buryat"
+RU,83,"Vladimir"
+RU,84,"Volgograd"
+RU,85,"Vologda"
+RU,86,"Voronezh"
+RU,87,"Yamal-Nenets"
+RU,88,"Yaroslavl'"
+RU,89,"Yevrey"
+RU,90,"Permskiy Kray"
+RU,91,"Krasnoyarskiy Kray"
+RW,01,"Butare"
+RW,06,"Gitarama"
+RW,09,"Kigali"
+RW,11,"Est"
+RW,12,"Kigali"
+RW,13,"Nord"
+RW,14,"Ouest"
+RW,15,"Sud"
+SA,02,"Al Bahah"
+SA,03,"Al Jawf"
+SA,05,"Al Madinah"
+SA,06,"Ash Sharqiyah"
+SA,08,"Al Qasim"
+SA,09,"Al Qurayyat"
+SA,10,"Ar Riyad"
+SA,13,"Ha'il"
+SA,14,"Makkah"
+SA,15,"Al Hudud ash Shamaliyah"
+SA,16,"Najran"
+SA,17,"Jizan"
+SA,19,"Tabuk"
+SA,20,"Al Jawf"
+SB,03,"Malaita"
+SB,06,"Guadalcanal"
+SB,07,"Isabel"
+SB,08,"Makira"
+SB,09,"Temotu"
+SB,10,"Central"
+SB,11,"Western"
+SB,12,"Choiseul"
+SB,13,"Rennell and Bellona"
+SC,01,"Anse aux Pins"
+SC,02,"Anse Boileau"
+SC,03,"Anse Etoile"
+SC,04,"Anse Louis"
+SC,05,"Anse Royale"
+SC,06,"Baie Lazare"
+SC,07,"Baie Sainte Anne"
+SC,08,"Beau Vallon"
+SC,09,"Bel Air"
+SC,10,"Bel Ombre"
+SC,11,"Cascade"
+SC,12,"Glacis"
+SC,13,"Grand' Anse"
+SC,14,"Grand' Anse"
+SC,15,"La Digue"
+SC,16,"La Riviere Anglaise"
+SC,17,"Mont Buxton"
+SC,18,"Mont Fleuri"
+SC,19,"Plaisance"
+SC,20,"Pointe La Rue"
+SC,21,"Port Glaud"
+SC,22,"Saint Louis"
+SC,23,"Takamaka"
+SD,27,"Al Wusta"
+SD,28,"Al Istiwa'iyah"
+SD,29,"Al Khartum"
+SD,30,"Ash Shamaliyah"
+SD,31,"Ash Sharqiyah"
+SD,32,"Bahr al Ghazal"
+SD,33,"Darfur"
+SD,34,"Kurdufan"
+SD,35,"Upper Nile"
+SE,01,"Alvsborgs Lan"
+SE,02,"Blekinge Lan"
+SE,03,"Gavleborgs Lan"
+SE,04,"Goteborgs och Bohus Lan"
+SE,05,"Gotlands Lan"
+SE,06,"Hallands Lan"
+SE,07,"Jamtlands Lan"
+SE,08,"Jonkopings Lan"
+SE,09,"Kalmar Lan"
+SE,10,"Dalarnas Lan"
+SE,11,"Kristianstads Lan"
+SE,12,"Kronobergs Lan"
+SE,13,"Malmohus Lan"
+SE,14,"Norrbottens Lan"
+SE,15,"Orebro Lan"
+SE,16,"Ostergotlands Lan"
+SE,17,"Skaraborgs Lan"
+SE,18,"Sodermanlands Lan"
+SE,21,"Uppsala Lan"
+SE,22,"Varmlands Lan"
+SE,23,"Vasterbottens Lan"
+SE,24,"Vasternorrlands Lan"
+SE,25,"Vastmanlands Lan"
+SE,26,"Stockholms Lan"
+SE,27,"Skane Lan"
+SE,28,"Vastra Gotaland"
+SH,01,"Ascension"
+SH,02,"Saint Helena"
+SH,03,"Tristan da Cunha"
+SI,01,"Ajdovscina"
+SI,02,"Beltinci"
+SI,03,"Bled"
+SI,04,"Bohinj"
+SI,05,"Borovnica"
+SI,06,"Bovec"
+SI,07,"Brda"
+SI,08,"Brezice"
+SI,09,"Brezovica"
+SI,11,"Celje"
+SI,12,"Cerklje na Gorenjskem"
+SI,13,"Cerknica"
+SI,14,"Cerkno"
+SI,15,"Crensovci"
+SI,16,"Crna na Koroskem"
+SI,17,"Crnomelj"
+SI,19,"Divaca"
+SI,20,"Dobrepolje"
+SI,22,"Dol pri Ljubljani"
+SI,24,"Dornava"
+SI,25,"Dravograd"
+SI,26,"Duplek"
+SI,27,"Gorenja Vas-Poljane"
+SI,28,"Gorisnica"
+SI,29,"Gornja Radgona"
+SI,30,"Gornji Grad"
+SI,31,"Gornji Petrovci"
+SI,32,"Grosuplje"
+SI,34,"Hrastnik"
+SI,35,"Hrpelje-Kozina"
+SI,36,"Idrija"
+SI,37,"Ig"
+SI,38,"Ilirska Bistrica"
+SI,39,"Ivancna Gorica"
+SI,40,"Izola-Isola"
+SI,42,"Jursinci"
+SI,44,"Kanal"
+SI,45,"Kidricevo"
+SI,46,"Kobarid"
+SI,47,"Kobilje"
+SI,49,"Komen"
+SI,50,"Koper-Capodistria"
+SI,51,"Kozje"
+SI,52,"Kranj"
+SI,53,"Kranjska Gora"
+SI,54,"Krsko"
+SI,55,"Kungota"
+SI,57,"Lasko"
+SI,61,"Ljubljana"
+SI,62,"Ljubno"
+SI,64,"Logatec"
+SI,66,"Loski Potok"
+SI,68,"Lukovica"
+SI,71,"Medvode"
+SI,72,"Menges"
+SI,73,"Metlika"
+SI,74,"Mezica"
+SI,76,"Mislinja"
+SI,77,"Moravce"
+SI,78,"Moravske Toplice"
+SI,79,"Mozirje"
+SI,80,"Murska Sobota"
+SI,81,"Muta"
+SI,82,"Naklo"
+SI,83,"Nazarje"
+SI,84,"Nova Gorica"
+SI,86,"Odranci"
+SI,87,"Ormoz"
+SI,88,"Osilnica"
+SI,89,"Pesnica"
+SI,91,"Pivka"
+SI,92,"Podcetrtek"
+SI,94,"Postojna"
+SI,97,"Puconci"
+SI,98,"Racam"
+SI,99,"Radece"
+SI,A1,"Radenci"
+SI,A2,"Radlje ob Dravi"
+SI,A3,"Radovljica"
+SI,A6,"Rogasovci"
+SI,A7,"Rogaska Slatina"
+SI,A8,"Rogatec"
+SI,B1,"Semic"
+SI,B2,"Sencur"
+SI,B3,"Sentilj"
+SI,B4,"Sentjernej"
+SI,B6,"Sevnica"
+SI,B7,"Sezana"
+SI,B8,"Skocjan"
+SI,B9,"Skofja Loka"
+SI,C1,"Skofljica"
+SI,C2,"Slovenj Gradec"
+SI,C4,"Slovenske Konjice"
+SI,C5,"Smarje pri Jelsah"
+SI,C6,"Smartno ob Paki"
+SI,C7,"Sostanj"
+SI,C8,"Starse"
+SI,C9,"Store"
+SI,D1,"Sveti Jurij"
+SI,D2,"Tolmin"
+SI,D3,"Trbovlje"
+SI,D4,"Trebnje"
+SI,D5,"Trzic"
+SI,D6,"Turnisce"
+SI,D7,"Velenje"
+SI,D8,"Velike Lasce"
+SI,E1,"Vipava"
+SI,E2,"Vitanje"
+SI,E3,"Vodice"
+SI,E5,"Vrhnika"
+SI,E6,"Vuzenica"
+SI,E7,"Zagorje ob Savi"
+SI,E9,"Zavrc"
+SI,F1,"Zelezniki"
+SI,F2,"Ziri"
+SI,F3,"Zrece"
+SI,G4,"Dobrova-Horjul-Polhov Gradec"
+SI,G7,"Domzale"
+SI,H4,"Jesenice"
+SI,H6,"Kamnik"
+SI,H7,"Kocevje"
+SI,I2,"Kuzma"
+SI,I3,"Lenart"
+SI,I5,"Litija"
+SI,I6,"Ljutomer"
+SI,I7,"Loska Dolina"
+SI,I9,"Luce"
+SI,J1,"Majsperk"
+SI,J2,"Maribor"
+SI,J5,"Miren-Kostanjevica"
+SI,J7,"Novo Mesto"
+SI,J9,"Piran"
+SI,K5,"Preddvor"
+SI,K7,"Ptuj"
+SI,L1,"Ribnica"
+SI,L3,"Ruse"
+SI,L7,"Sentjur pri Celju"
+SI,L8,"Slovenska Bistrica"
+SI,N2,"Videm"
+SI,N3,"Vojnik"
+SI,N5,"Zalec"
+SK,01,"Banska Bystrica"
+SK,02,"Bratislava"
+SK,03,"Kosice"
+SK,04,"Nitra"
+SK,05,"Presov"
+SK,06,"Trencin"
+SK,07,"Trnava"
+SK,08,"Zilina"
+SL,01,"Eastern"
+SL,02,"Northern"
+SL,03,"Southern"
+SL,04,"Western Area"
+SM,01,"Acquaviva"
+SM,02,"Chiesanuova"
+SM,03,"Domagnano"
+SM,04,"Faetano"
+SM,05,"Fiorentino"
+SM,06,"Borgo Maggiore"
+SM,07,"San Marino"
+SM,08,"Monte Giardino"
+SM,09,"Serravalle"
+SN,01,"Dakar"
+SN,03,"Diourbel"
+SN,04,"Saint-Louis"
+SN,05,"Tambacounda"
+SN,07,"Thies"
+SN,09,"Fatick"
+SN,10,"Kaolack"
+SN,11,"Kolda"
+SN,12,"Ziguinchor"
+SN,13,"Louga"
+SN,14,"Saint-Louis"
+SN,15,"Matam"
+SO,01,"Bakool"
+SO,02,"Banaadir"
+SO,03,"Bari"
+SO,04,"Bay"
+SO,05,"Galguduud"
+SO,06,"Gedo"
+SO,07,"Hiiraan"
+SO,08,"Jubbada Dhexe"
+SO,09,"Jubbada Hoose"
+SO,10,"Mudug"
+SO,11,"Nugaal"
+SO,12,"Sanaag"
+SO,13,"Shabeellaha Dhexe"
+SO,14,"Shabeellaha Hoose"
+SO,16,"Woqooyi Galbeed"
+SO,18,"Nugaal"
+SO,19,"Togdheer"
+SO,20,"Woqooyi Galbeed"
+SO,21,"Awdal"
+SO,22,"Sool"
+SR,10,"Brokopondo"
+SR,11,"Commewijne"
+SR,12,"Coronie"
+SR,13,"Marowijne"
+SR,14,"Nickerie"
+SR,15,"Para"
+SR,16,"Paramaribo"
+SR,17,"Saramacca"
+SR,18,"Sipaliwini"
+SR,19,"Wanica"
+ST,01,"Principe"
+ST,02,"Sao Tome"
+SV,01,"Ahuachapan"
+SV,02,"Cabanas"
+SV,03,"Chalatenango"
+SV,04,"Cuscatlan"
+SV,05,"La Libertad"
+SV,06,"La Paz"
+SV,07,"La Union"
+SV,08,"Morazan"
+SV,09,"San Miguel"
+SV,10,"San Salvador"
+SV,11,"Santa Ana"
+SV,12,"San Vicente"
+SV,13,"Sonsonate"
+SV,14,"Usulutan"
+SY,01,"Al Hasakah"
+SY,02,"Al Ladhiqiyah"
+SY,03,"Al Qunaytirah"
+SY,04,"Ar Raqqah"
+SY,05,"As Suwayda'"
+SY,06,"Dar"
+SY,07,"Dayr az Zawr"
+SY,08,"Rif Dimashq"
+SY,09,"Halab"
+SY,10,"Hamah"
+SY,11,"Hims"
+SY,12,"Idlib"
+SY,13,"Dimashq"
+SY,14,"Tartus"
+SZ,01,"Hhohho"
+SZ,02,"Lubombo"
+SZ,03,"Manzini"
+SZ,04,"Shiselweni"
+SZ,05,"Praslin"
+TD,01,"Batha"
+TD,02,"Biltine"
+TD,03,"Borkou-Ennedi-Tibesti"
+TD,04,"Chari-Baguirmi"
+TD,05,"Guera"
+TD,06,"Kanem"
+TD,07,"Lac"
+TD,08,"Logone Occidental"
+TD,09,"Logone Oriental"
+TD,10,"Mayo-Kebbi"
+TD,11,"Moyen-Chari"
+TD,12,"Ouaddai"
+TD,13,"Salamat"
+TD,14,"Tandjile"
+TG,09,"Lama-Kara"
+TG,18,"Tsevie"
+TG,22,"Centrale"
+TG,23,"Kara"
+TG,24,"Maritime"
+TG,25,"Plateaux"
+TG,26,"Savanes"
+TH,01,"Mae Hong Son"
+TH,02,"Chiang Mai"
+TH,03,"Chiang Rai"
+TH,04,"Nan"
+TH,05,"Lamphun"
+TH,06,"Lampang"
+TH,07,"Phrae"
+TH,08,"Tak"
+TH,09,"Sukhothai"
+TH,10,"Uttaradit"
+TH,11,"Kamphaeng Phet"
+TH,12,"Phitsanulok"
+TH,13,"Phichit"
+TH,14,"Phetchabun"
+TH,15,"Uthai Thani"
+TH,16,"Nakhon Sawan"
+TH,17,"Nong Khai"
+TH,18,"Loei"
+TH,20,"Sakon Nakhon"
+TH,21,"Nakhon Phanom"
+TH,22,"Khon Kaen"
+TH,23,"Kalasin"
+TH,24,"Maha Sarakham"
+TH,25,"Roi Et"
+TH,26,"Chaiyaphum"
+TH,27,"Nakhon Ratchasima"
+TH,28,"Buriram"
+TH,29,"Surin"
+TH,30,"Sisaket"
+TH,31,"Narathiwat"
+TH,32,"Chai Nat"
+TH,33,"Sing Buri"
+TH,34,"Lop Buri"
+TH,35,"Ang Thong"
+TH,36,"Phra Nakhon Si Ayutthaya"
+TH,37,"Saraburi"
+TH,38,"Nonthaburi"
+TH,39,"Pathum Thani"
+TH,40,"Krung Thep"
+TH,41,"Phayao"
+TH,42,"Samut Prakan"
+TH,43,"Nakhon Nayok"
+TH,44,"Chachoengsao"
+TH,45,"Prachin Buri"
+TH,46,"Chon Buri"
+TH,47,"Rayong"
+TH,48,"Chanthaburi"
+TH,49,"Trat"
+TH,50,"Kanchanaburi"
+TH,51,"Suphan Buri"
+TH,52,"Ratchaburi"
+TH,53,"Nakhon Pathom"
+TH,54,"Samut Songkhram"
+TH,55,"Samut Sakhon"
+TH,56,"Phetchaburi"
+TH,57,"Prachuap Khiri Khan"
+TH,58,"Chumphon"
+TH,59,"Ranong"
+TH,60,"Surat Thani"
+TH,61,"Phangnga"
+TH,62,"Phuket"
+TH,63,"Krabi"
+TH,64,"Nakhon Si Thammarat"
+TH,65,"Trang"
+TH,66,"Phatthalung"
+TH,67,"Satun"
+TH,68,"Songkhla"
+TH,69,"Pattani"
+TH,70,"Yala"
+TH,71,"Ubon Ratchathani"
+TH,72,"Yasothon"
+TH,75,"Ubon Ratchathani"
+TH,76,"Udon Thani"
+TH,78,"Mukdahan"
+TJ,01,"Kuhistoni Badakhshon"
+TJ,02,"Khatlon"
+TJ,03,"Sughd"
+TM,01,"Ahal"
+TM,02,"Balkan"
+TM,03,"Dashoguz"
+TM,04,"Lebap"
+TM,05,"Mary"
+TN,02,"Al Qasrayn"
+TN,03,"Al Qayrawan"
+TN,06,"Jundubah"
+TN,10,"Qafsah"
+TN,14,"Kef"
+TN,15,"Al Mahdiyah"
+TN,16,"Al Munastir"
+TN,17,"Bajah"
+TN,18,"Banzart"
+TN,19,"Nabul"
+TN,22,"Silyanah"
+TN,23,"Susah"
+TN,27,"Bin"
+TN,28,"Madanin"
+TN,29,"Qabis"
+TN,30,"Qafşah"
+TN,31,"Qibili"
+TN,32,"Safaqis"
+TN,33,"Sidi Bu Zayd"
+TN,34,"Tatawin"
+TN,35,"Tawzar"
+TN,36,"Tunis"
+TN,37,"Zaghwan"
+TN,38,"Ariana"
+TN,39,"Manouba"
+TO,01,"Ha"
+TO,02,"Tongatapu"
+TO,03,"Vava"
+TR,02,"Adiyaman"
+TR,03,"Afyonkarahisar"
+TR,04,"Agri"
+TR,05,"Amasya"
+TR,07,"Antalya"
+TR,08,"Artvin"
+TR,09,"Aydin"
+TR,10,"Balikesir"
+TR,11,"Bilecik"
+TR,12,"Bingol"
+TR,13,"Bitlis"
+TR,14,"Bolu"
+TR,15,"Burdur"
+TR,16,"Bursa"
+TR,17,"Canakkale"
+TR,19,"Corum"
+TR,20,"Denizli"
+TR,21,"Diyarbakir"
+TR,22,"Edirne"
+TR,23,"Elazig"
+TR,24,"Erzincan"
+TR,25,"Erzurum"
+TR,26,"Eskisehir"
+TR,28,"Giresun"
+TR,31,"Hatay"
+TR,32,"Icel"
+TR,33,"Isparta"
+TR,34,"Istanbul"
+TR,35,"Izmir"
+TR,37,"Kastamonu"
+TR,38,"Kayseri"
+TR,39,"Kirklareli"
+TR,40,"Kirsehir"
+TR,41,"Kocaeli"
+TR,43,"Kutahya"
+TR,44,"Malatya"
+TR,45,"Manisa"
+TR,46,"Kahramanmaras"
+TR,48,"Mugla"
+TR,49,"Mus"
+TR,50,"Nevsehir"
+TR,52,"Ordu"
+TR,53,"Rize"
+TR,54,"Sakarya"
+TR,55,"Samsun"
+TR,57,"Sinop"
+TR,58,"Sivas"
+TR,59,"Tekirdag"
+TR,60,"Tokat"
+TR,61,"Trabzon"
+TR,62,"Tunceli"
+TR,63,"Sanliurfa"
+TR,64,"Usak"
+TR,65,"Van"
+TR,66,"Yozgat"
+TR,68,"Ankara"
+TR,69,"Gumushane"
+TR,70,"Hakkari"
+TR,71,"Konya"
+TR,72,"Mardin"
+TR,73,"Nigde"
+TR,74,"Siirt"
+TR,75,"Aksaray"
+TR,76,"Batman"
+TR,77,"Bayburt"
+TR,78,"Karaman"
+TR,79,"Kirikkale"
+TR,80,"Sirnak"
+TR,81,"Adana"
+TR,82,"Cankiri"
+TR,83,"Gaziantep"
+TR,84,"Kars"
+TR,85,"Zonguldak"
+TR,86,"Ardahan"
+TR,87,"Bartin"
+TR,88,"Igdir"
+TR,89,"Karabuk"
+TR,90,"Kilis"
+TR,91,"Osmaniye"
+TR,92,"Yalova"
+TR,93,"Duzce"
+TT,01,"Arima"
+TT,02,"Caroni"
+TT,03,"Mayaro"
+TT,04,"Nariva"
+TT,05,"Port-of-Spain"
+TT,06,"Saint Andrew"
+TT,07,"Saint David"
+TT,08,"Saint George"
+TT,09,"Saint Patrick"
+TT,10,"San Fernando"
+TT,11,"Tobago"
+TT,12,"Victoria"
+TW,01,"Fu-chien"
+TW,02,"Kao-hsiung"
+TW,03,"T'ai-pei"
+TW,04,"T'ai-wan"
+TZ,02,"Pwani"
+TZ,03,"Dodoma"
+TZ,04,"Iringa"
+TZ,05,"Kigoma"
+TZ,06,"Kilimanjaro"
+TZ,07,"Lindi"
+TZ,08,"Mara"
+TZ,09,"Mbeya"
+TZ,10,"Morogoro"
+TZ,11,"Mtwara"
+TZ,12,"Mwanza"
+TZ,13,"Pemba North"
+TZ,14,"Ruvuma"
+TZ,15,"Shinyanga"
+TZ,16,"Singida"
+TZ,17,"Tabora"
+TZ,18,"Tanga"
+TZ,19,"Kagera"
+TZ,20,"Pemba South"
+TZ,21,"Zanzibar Central"
+TZ,22,"Zanzibar North"
+TZ,23,"Dar es Salaam"
+TZ,24,"Rukwa"
+TZ,25,"Zanzibar Urban"
+TZ,26,"Arusha"
+TZ,27,"Manyara"
+UA,01,"Cherkas'ka Oblast'"
+UA,02,"Chernihivs'ka Oblast'"
+UA,03,"Chernivets'ka Oblast'"
+UA,04,"Dnipropetrovs'ka Oblast'"
+UA,05,"Donets'ka Oblast'"
+UA,06,"Ivano-Frankivs'ka Oblast'"
+UA,07,"Kharkivs'ka Oblast'"
+UA,08,"Khersons'ka Oblast'"
+UA,09,"Khmel'nyts'ka Oblast'"
+UA,10,"Kirovohrads'ka Oblast'"
+UA,11,"Krym"
+UA,12,"Kyyiv"
+UA,13,"Kyyivs'ka Oblast'"
+UA,14,"Luhans'ka Oblast'"
+UA,15,"L'vivs'ka Oblast'"
+UA,16,"Mykolayivs'ka Oblast'"
+UA,17,"Odes'ka Oblast'"
+UA,18,"Poltavs'ka Oblast'"
+UA,19,"Rivnens'ka Oblast'"
+UA,20,"Sevastopol'"
+UA,21,"Sums'ka Oblast'"
+UA,22,"Ternopil's'ka Oblast'"
+UA,23,"Vinnyts'ka Oblast'"
+UA,24,"Volyns'ka Oblast'"
+UA,25,"Zakarpats'ka Oblast'"
+UA,26,"Zaporiz'ka Oblast'"
+UA,27,"Zhytomyrs'ka Oblast'"
+UG,05,"Busoga"
+UG,08,"Karamoja"
+UG,12,"South Buganda"
+UG,18,"Central"
+UG,20,"Eastern"
+UG,21,"Nile"
+UG,22,"North Buganda"
+UG,23,"Northern"
+UG,24,"Southern"
+UG,25,"Western"
+UG,37,"Kampala"
+UG,56,"Mubende"
+UG,65,"Adjumani"
+UG,66,"Bugiri"
+UG,67,"Busia"
+UG,69,"Katakwi"
+UG,73,"Nakasongola"
+UG,74,"Sembabule"
+UG,77,"Arua"
+UG,78,"Iganga"
+UG,79,"Kabarole"
+UG,80,"Kaberamaido"
+UG,81,"Kamwenge"
+UG,82,"Kanungu"
+UG,83,"Kayunga"
+UG,84,"Kitgum"
+UG,85,"Kyenjojo"
+UG,86,"Mayuge"
+UG,87,"Mbale"
+UG,88,"Moroto"
+UG,89,"Mpigi"
+UG,90,"Mukono"
+UG,91,"Nakapiripirit"
+UG,92,"Pader"
+UG,93,"Rukungiri"
+UG,94,"Sironko"
+UG,95,"Soroti"
+UG,96,"Wakiso"
+UG,97,"Yumbe"
+US,01,"Alabama"
+US,02,"Alaska"
+US,04,"Arizona"
+US,05,"Arkansas"
+US,06,"California"
+US,08,"Colorado"
+US,09,"Connecticut"
+US,10,"Delaware"
+US,11,"District of Columbia"
+US,12,"Florida"
+US,13,"Georgia"
+US,15,"Hawaii"
+US,16,"Idaho"
+US,17,"Illinois"
+US,18,"Indiana"
+US,19,"Iowa"
+US,20,"Kansas"
+US,21,"Kentucky"
+US,22,"Louisiana"
+US,23,"Maine"
+US,24,"Maryland"
+US,25,"Massachusetts"
+US,26,"Michigan"
+US,27,"Minnesota"
+US,28,"Mississippi"
+US,29,"Missouri"
+US,30,"Montana"
+US,31,"Nebraska"
+US,32,"Nevada"
+US,33,"New Hampshire"
+US,34,"New Jersey"
+US,35,"New Mexico"
+US,36,"New York"
+US,37,"North Carolina"
+US,38,"North Dakota"
+US,39,"Ohio"
+US,40,"Oklahoma"
+US,41,"Oregon"
+US,42,"Pennsylvania"
+US,44,"Rhode Island"
+US,45,"South Carolina"
+US,46,"South Dakota"
+US,47,"Tennessee"
+US,48,"Texas"
+US,49,"Utah"
+US,50,"Vermont"
+US,51,"Virginia"
+US,53,"Washington"
+US,54,"West Virginia"
+US,55,"Wisconsin"
+US,56,"Wyoming"
+UY,01,"Artigas"
+UY,02,"Canelones"
+UY,03,"Cerro Largo"
+UY,04,"Colonia"
+UY,05,"Durazno"
+UY,06,"Flores"
+UY,07,"Florida"
+UY,08,"Lavalleja"
+UY,09,"Maldonado"
+UY,10,"Montevideo"
+UY,11,"Paysandu"
+UY,12,"Rio Negro"
+UY,13,"Rivera"
+UY,14,"Rocha"
+UY,15,"Salto"
+UY,16,"San Jose"
+UY,17,"Soriano"
+UY,18,"Tacuarembo"
+UY,19,"Treinta y Tres"
+UZ,01,"Andijon"
+UZ,02,"Bukhoro"
+UZ,03,"Farghona"
+UZ,04,"Jizzakh"
+UZ,05,"Khorazm"
+UZ,06,"Namangan"
+UZ,07,"Nawoiy"
+UZ,08,"Qashqadaryo"
+UZ,09,"Qoraqalpoghiston"
+UZ,10,"Samarqand"
+UZ,11,"Sirdaryo"
+UZ,12,"Surkhondaryo"
+UZ,13,"Toshkent"
+UZ,14,"Toshkent"
+VC,01,"Charlotte"
+VC,02,"Saint Andrew"
+VC,03,"Saint David"
+VC,04,"Saint George"
+VC,05,"Saint Patrick"
+VC,06,"Grenadines"
+VE,01,"Amazonas"
+VE,02,"Anzoategui"
+VE,03,"Apure"
+VE,04,"Aragua"
+VE,05,"Barinas"
+VE,06,"Bolivar"
+VE,07,"Carabobo"
+VE,08,"Cojedes"
+VE,09,"Delta Amacuro"
+VE,11,"Falcon"
+VE,12,"Guarico"
+VE,13,"Lara"
+VE,14,"Merida"
+VE,15,"Miranda"
+VE,16,"Monagas"
+VE,17,"Nueva Esparta"
+VE,18,"Portuguesa"
+VE,19,"Sucre"
+VE,20,"Tachira"
+VE,21,"Trujillo"
+VE,22,"Yaracuy"
+VE,23,"Zulia"
+VE,24,"Dependencias Federales"
+VE,25,"Distrito Federal"
+VE,26,"Vargas"
+VN,01,"An Giang"
+VN,02,"Bac Thai"
+VN,03,"Ben Tre"
+VN,04,"Binh Tri Thien"
+VN,05,"Cao Bang"
+VN,07,"Dac Lac"
+VN,09,"Dong Thap"
+VN,11,"Ha Bac"
+VN,12,"Hai Hung"
+VN,13,"Hai Phong"
+VN,14,"Ha Nam Ninh"
+VN,16,"Ha Son Binh"
+VN,17,"Ha Tuyen"
+VN,19,"Hoang Lien Son"
+VN,20,"Ho Chi Minh"
+VN,21,"Kien Giang"
+VN,22,"Lai Chau"
+VN,23,"Lam Dong"
+VN,24,"Long An"
+VN,25,"Minh Hai"
+VN,26,"Nghe Tinh"
+VN,27,"Nghia Binh"
+VN,28,"Phu Khanh"
+VN,29,"Quang Nam-Da Nang"
+VN,30,"Quang Ninh"
+VN,31,"Song Be"
+VN,32,"Son La"
+VN,33,"Tay Ninh"
+VN,34,"Thanh Hoa"
+VN,35,"Thai Binh"
+VN,36,"Thuan Hai"
+VN,37,"Tien Giang"
+VN,38,"Vinh Phu"
+VN,39,"Lang Son"
+VN,40,"Dong Nai"
+VN,43,"An Giang"
+VN,44,"Dac Lac"
+VN,45,"Dong Nai"
+VN,46,"Dong Thap"
+VN,47,"Kien Giang"
+VN,48,"Minh Hai"
+VN,49,"Song Be"
+VN,50,"Vinh Phu"
+VN,51,"Ha Noi"
+VN,52,"Ho Chi Minh"
+VN,53,"Ba Ria-Vung Tau"
+VN,54,"Binh Dinh"
+VN,55,"Binh Thuan"
+VN,56,"Can Tho"
+VN,57,"Gia Lai"
+VN,58,"Ha Giang"
+VN,59,"Ha Tay"
+VN,60,"Ha Tinh"
+VN,61,"Hoa Binh"
+VN,62,"Khanh Hoa"
+VN,63,"Kon Tum"
+VN,64,"Quang Tri"
+VN,65,"Nam Ha"
+VN,66,"Nghe An"
+VN,67,"Ninh Binh"
+VN,68,"Ninh Thuan"
+VN,69,"Phu Yen"
+VN,70,"Quang Binh"
+VN,71,"Quang Ngai"
+VN,72,"Quang Tri"
+VN,73,"Soc Trang"
+VN,74,"Thua Thien"
+VN,75,"Tra Vinh"
+VN,76,"Tuyen Quang"
+VN,77,"Vinh Long"
+VN,78,"Da Nang"
+VN,79,"Hai Duong"
+VN,80,"Ha Nam"
+VN,81,"Hung Yen"
+VN,82,"Nam Dinh"
+VN,83,"Phu Tho"
+VN,84,"Quang Nam"
+VN,85,"Thai Nguyen"
+VN,87,"Can Tho"
+VN,88,"Dak Lak"
+VN,89,"Lai Chau"
+VN,90,"Lao Cai"
+VN,91,"Dak Nong"
+VN,92,"Dien Bien"
+VN,93,"Hau Giang"
+VU,05,"Ambrym"
+VU,06,"Aoba"
+VU,07,"Torba"
+VU,08,"Efate"
+VU,09,"Epi"
+VU,10,"Malakula"
+VU,11,"Paama"
+VU,12,"Pentecote"
+VU,13,"Sanma"
+VU,14,"Shepherd"
+VU,15,"Tafea"
+VU,16,"Malampa"
+VU,17,"Penama"
+VU,18,"Shefa"
+WS,02,"Aiga-i-le-Tai"
+WS,03,"Atua"
+WS,04,"Fa"
+WS,05,"Gaga"
+WS,06,"Va"
+WS,07,"Gagaifomauga"
+WS,08,"Palauli"
+WS,09,"Satupa"
+WS,10,"Tuamasaga"
+WS,11,"Vaisigano"
+YE,01,"Abyan"
+YE,02,"Adan"
+YE,03,"Al Mahrah"
+YE,04,"Hadramawt"
+YE,05,"Shabwah"
+YE,08,"Al Hudaydah"
+YE,10,"Al Mahwit"
+YE,11,"Dhamar"
+YE,14,"Ma'rib"
+YE,15,"Sa"
+YE,16,"San"
+YE,20,"Al Bayda'"
+YE,21,"Al Jawf"
+YE,22,"Hajjah"
+YE,23,"Ibb"
+YE,24,"Lahij"
+YE,25,"Ta"
+ZA,02,"KwaZulu-Natal"
+ZA,03,"Free State"
+ZA,05,"Eastern Cape"
+ZA,06,"Gauteng"
+ZA,07,"Mpumalanga"
+ZA,08,"Northern Cape"
+ZA,09,"Limpopo"
+ZA,10,"North-West"
+ZA,11,"Western Cape"
+ZM,01,"Western"
+ZM,02,"Central"
+ZM,03,"Eastern"
+ZM,04,"Luapula"
+ZM,05,"Northern"
+ZM,06,"North-Western"
+ZM,07,"Southern"
+ZM,08,"Copperbelt"
+ZM,09,"Lusaka"
+ZW,01,"Manicaland"
+ZW,02,"Midlands"
+ZW,03,"Mashonaland Central"
+ZW,04,"Mashonaland East"
+ZW,05,"Mashonaland West"
+ZW,06,"Matabeleland North"
+ZW,07,"Matabeleland South"
+ZW,08,"Masvingo"
+ZW,09,"Bulawayo"
+ZW,10,"Harare"
--- /dev/null
+A1,"Anonymous Proxy"
+A2,"Satellite Provider"
+AD,"Andorra"
+AE,"United Arab Emirates"
+AF,"Afghanistan"
+AG,"Antigua and Barbuda"
+AI,"Anguilla"
+AL,"Albania"
+AM,"Armenia"
+AN,"Netherlands Antilles"
+AO,"Angola"
+AP,"Asia/Pacific Region"
+AQ,"Antarctica"
+AR,"Argentina"
+AS,"American Samoa"
+AT,"Austria"
+AU,"Australia"
+AW,"Aruba"
+AX,"Aland Islands"
+AZ,"Azerbaijan"
+BA,"Bosnia and Herzegovina"
+BB,"Barbados"
+BD,"Bangladesh"
+BE,"Belgium"
+BF,"Burkina Faso"
+BG,"Bulgaria"
+BH,"Bahrain"
+BI,"Burundi"
+BJ,"Benin"
+BM,"Bermuda"
+BN,"Brunei Darussalam"
+BO,"Bolivia"
+BR,"Brazil"
+BS,"Bahamas"
+BT,"Bhutan"
+BV,"Bouvet Island"
+BW,"Botswana"
+BY,"Belarus"
+BZ,"Belize"
+CA,"Canada"
+CC,"Cocos (Keeling) Islands"
+CD,"Congo, The Democratic Republic of the"
+CF,"Central African Republic"
+CG,"Congo"
+CH,"Switzerland"
+CI,"Cote d'Ivoire"
+CK,"Cook Islands"
+CL,"Chile"
+CM,"Cameroon"
+CN,"China"
+CO,"Colombia"
+CR,"Costa Rica"
+CU,"Cuba"
+CV,"Cape Verde"
+CX,"Christmas Island"
+CY,"Cyprus"
+CZ,"Czech Republic"
+DE,"Germany"
+DJ,"Djibouti"
+DK,"Denmark"
+DM,"Dominica"
+DO,"Dominican Republic"
+DZ,"Algeria"
+EC,"Ecuador"
+EE,"Estonia"
+EG,"Egypt"
+EH,"Western Sahara"
+ER,"Eritrea"
+ES,"Spain"
+ET,"Ethiopia"
+EU,"Europe"
+FI,"Finland"
+FJ,"Fiji"
+FK,"Falkland Islands (Malvinas)"
+FM,"Micronesia, Federated States of"
+FO,"Faroe Islands"
+FR,"France"
+GA,"Gabon"
+GB,"United Kingdom"
+GD,"Grenada"
+GE,"Georgia"
+GF,"French Guiana"
+GG,"Guernsey"
+GH,"Ghana"
+GI,"Gibraltar"
+GL,"Greenland"
+GM,"Gambia"
+GN,"Guinea"
+GP,"Guadeloupe"
+GQ,"Equatorial Guinea"
+GR,"Greece"
+GS,"South Georgia and the South Sandwich Islands"
+GT,"Guatemala"
+GU,"Guam"
+GW,"Guinea-Bissau"
+GY,"Guyana"
+HK,"Hong Kong"
+HM,"Heard Island and McDonald Islands"
+HN,"Honduras"
+HR,"Croatia"
+HT,"Haiti"
+HU,"Hungary"
+ID,"Indonesia"
+IE,"Ireland"
+IL,"Israel"
+IM,"Isle of Man"
+IN,"India"
+IO,"British Indian Ocean Territory"
+IQ,"Iraq"
+IR,"Iran, Islamic Republic of"
+IS,"Iceland"
+IT,"Italy"
+JE,"Jersey"
+JM,"Jamaica"
+JO,"Jordan"
+JP,"Japan"
+KE,"Kenya"
+KG,"Kyrgyzstan"
+KH,"Cambodia"
+KI,"Kiribati"
+KM,"Comoros"
+KN,"Saint Kitts and Nevis"
+KP,"Korea, Democratic People's Republic of"
+KR,"Korea, Republic of"
+KW,"Kuwait"
+KY,"Cayman Islands"
+KZ,"Kazakhstan"
+LA,"Lao People's Democratic Republic"
+LB,"Lebanon"
+LC,"Saint Lucia"
+LI,"Liechtenstein"
+LK,"Sri Lanka"
+LR,"Liberia"
+LS,"Lesotho"
+LT,"Lithuania"
+LU,"Luxembourg"
+LV,"Latvia"
+LY,"Libyan Arab Jamahiriya"
+MA,"Morocco"
+MC,"Monaco"
+MD,"Moldova, Republic of"
+ME,"Montenegro"
+MG,"Madagascar"
+MH,"Marshall Islands"
+MK,"Macedonia"
+ML,"Mali"
+MM,"Myanmar"
+MN,"Mongolia"
+MO,"Macao"
+MP,"Northern Mariana Islands"
+MQ,"Martinique"
+MR,"Mauritania"
+MS,"Montserrat"
+MT,"Malta"
+MU,"Mauritius"
+MV,"Maldives"
+MW,"Malawi"
+MX,"Mexico"
+MY,"Malaysia"
+MZ,"Mozambique"
+NA,"Namibia"
+NC,"New Caledonia"
+NE,"Niger"
+NF,"Norfolk Island"
+NG,"Nigeria"
+NI,"Nicaragua"
+NL,"Netherlands"
+NO,"Norway"
+NP,"Nepal"
+NR,"Nauru"
+NU,"Niue"
+NZ,"New Zealand"
+OM,"Oman"
+PA,"Panama"
+PE,"Peru"
+PF,"French Polynesia"
+PG,"Papua New Guinea"
+PH,"Philippines"
+PK,"Pakistan"
+PL,"Poland"
+PM,"Saint Pierre and Miquelon"
+PN,"Pitcairn"
+PR,"Puerto Rico"
+PS,"Palestinian Territory"
+PT,"Portugal"
+PW,"Palau"
+PY,"Paraguay"
+QA,"Qatar"
+RE,"Reunion"
+RO,"Romania"
+RS,"Serbia"
+RU,"Russian Federation"
+RW,"Rwanda"
+SA,"Saudi Arabia"
+SB,"Solomon Islands"
+SC,"Seychelles"
+SD,"Sudan"
+SE,"Sweden"
+SG,"Singapore"
+SH,"Saint Helena"
+SI,"Slovenia"
+SJ,"Svalbard and Jan Mayen"
+SK,"Slovakia"
+SL,"Sierra Leone"
+SM,"San Marino"
+SN,"Senegal"
+SO,"Somalia"
+SR,"Suriname"
+ST,"Sao Tome and Principe"
+SV,"El Salvador"
+SY,"Syrian Arab Republic"
+SZ,"Swaziland"
+TC,"Turks and Caicos Islands"
+TD,"Chad"
+TF,"French Southern Territories"
+TG,"Togo"
+TH,"Thailand"
+TJ,"Tajikistan"
+TK,"Tokelau"
+TL,"Timor-Leste"
+TM,"Turkmenistan"
+TN,"Tunisia"
+TO,"Tonga"
+TR,"Turkey"
+TT,"Trinidad and Tobago"
+TV,"Tuvalu"
+TW,"Taiwan"
+TZ,"Tanzania, United Republic of"
+UA,"Ukraine"
+UG,"Uganda"
+UM,"United States Minor Outlying Islands"
+US,"United States"
+UY,"Uruguay"
+UZ,"Uzbekistan"
+VA,"Holy See (Vatican City State)"
+VC,"Saint Vincent and the Grenadines"
+VE,"Venezuela"
+VG,"Virgin Islands, British"
+VI,"Virgin Islands, U.S."
+VN,"Vietnam"
+VU,"Vanuatu"
+WF,"Wallis and Futuna"
+WS,"Samoa"
+YE,"Yemen"
+YT,"Mayotte"
+ZA,"South Africa"
+ZM,"Zambia"
+ZW,"Zimbabwe"
--- /dev/null
+iso 3166 country,iso 3166-2 region,name
+CA,AB,"Alberta"
+CA,BC,"British Columbia"
+CA,MB,"Manitoba"
+CA,NB,"New Brunswick"
+CA,NL,"Newfoundland"
+CA,NS,"Nova Scotia"
+CA,NU,"Nunavut"
+CA,ON,"Ontario"
+CA,PE,"Prince Edward Island"
+CA,QC,"Quebec"
+CA,SK,"Saskatchewan"
+CA,NT,"Northwest Territories"
+CA,YT,"Yukon Territory"
+US,AA,"Armed Forces Americas"
+US,AE,"Armed Forces Europe, Middle East, & Canada"
+US,AK,"Alaska"
+US,AL,"Alabama"
+US,AP,"Armed Forces Pacific"
+US,AR,"Arkansas"
+US,AS,"American Samoa"
+US,AZ,"Arizona"
+US,CA,"California"
+US,CO,"Colorado"
+US,CT,"Connecticut"
+US,DC,"District of Columbia"
+US,DE,"Delaware"
+US,FL,"Florida"
+US,FM,"Federated States of Micronesia"
+US,GA,"Georgia"
+US,GU,"Guam"
+US,HI,"Hawaii"
+US,IA,"Iowa"
+US,ID,"Idaho"
+US,IL,"Illinois"
+US,IN,"Indiana"
+US,KS,"Kansas"
+US,KY,"Kentucky"
+US,LA,"Louisiana"
+US,MA,"Massachusetts"
+US,MD,"Maryland"
+US,ME,"Maine"
+US,MH,"Marshall Islands"
+US,MI,"Michigan"
+US,MN,"Minnesota"
+US,MO,"Missouri"
+US,MP,"Northern Mariana Islands"
+US,MS,"Mississippi"
+US,MT,"Montana"
+US,NC,"North Carolina"
+US,ND,"North Dakota"
+US,NE,"Nebraska"
+US,NH,"New Hampshire"
+US,NJ,"New Jersey"
+US,NM,"New Mexico"
+US,NV,"Nevada"
+US,NY,"New York"
+US,OH,"Ohio"
+US,OK,"Oklahoma"
+US,OR,"Oregon"
+US,PA,"Pennsylvania"
+US,PR,"Puerto Rico"
+US,PW,"Palau"
+US,RI,"Rhode Island"
+US,SC,"South Carolina"
+US,SD,"South Dakota"
+US,TN,"Tennessee"
+US,TX,"Texas"
+US,UT,"Utah"
+US,VA,"Virginia"
+US,VI,"Virgin Islands"
+US,VT,"Vermont"
+US,WA,"Washington"
+US,WV,"West Virginia"
+US,WI,"Wisconsin"
+US,WY,"Wyoming"
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+use strict;
+
+use Getopt::Long;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => dirname(abs_path($0)),
+ );
+ require constant; import constant(\%constants);
+}
+
+chdir PREFIX;
+use lib PREFIX, "@{[PREFIX]}/CPAN";
+
+our ($delete_db, $skip_backup, $auto_backup, $restore, $help);
+BEGIN {
+ GetOptions (
+ "delete" => \$delete_db,
+ "skip-backup" => \$skip_backup,
+ "backup" => \$auto_backup,
+ "restore" => \$restore,
+ "help" => \$help,
+ );
+
+ if($help) {
+ print qq"
+Options:
+ --delete Delete entire database
+ --skip-backup Don't nag about making a backup
+ --backup Make backup without upgrading
+ --restore FILE Restore the database from a backup
+ --help Show this message
+";
+
+ exit 1;
+ }
+}
+
+use SrSv::Conf qw(main sql);
+use SrSv::DB::Schema;
+
+BEGIN {
+ if($restore) {
+ my $f = shift @ARGV;
+ $f or die "You must specify a backup file to restore.\n";
+ print "Restoring from backup...\n";
+ system("mysql $sql_conf{'mysql-db'} -u $sql_conf{'mysql-user'} --password=$sql_conf{'mysql-pass'} <$f");
+ print "Finished.\n";
+ exit;
+ }
+}
+
+use SrSv::MySQL '$dbh';
+
+use SrSv::Upgrade::HashPass;
+
+my $backup_file;
+
+sub ask($) {
+ print shift;
+
+ while(my $c = getc) {
+ next unless $c =~ /\S/;
+ return (lc $c eq 'y');
+ }
+}
+
+unless($skip_backup) {
+ if($auto_backup or ask "Would you like to make a backup of your database: $sql_conf{'mysql-db'}? (Y/n) ") {
+ my @lt = localtime();
+ $backup_file = "./db-backup-" . sprintf( "%04d%02d%02d", ($lt[5]+1900) , ($lt[4]+1) , ($lt[3]) ) . "-$$.sql";
+ print "Creating backup in $backup_file\n";
+ system("./utils/db-dump.pl > $backup_file");
+ goto END if $auto_backup;
+ }
+}
+
+if($delete_db) {
+ exit unless ask "Really delete all data in database: $sql_conf{'mysql-db'}? (y/N) ";
+
+ print "Deleting old tables...\n";
+
+ my $table_list = $dbh->prepare("SHOW TABLES");
+ $table_list->execute;
+ while(my $t = $table_list->fetchrow_array) {
+ $dbh->do("DROP TABLE $t");
+ }
+}
+
+$dbh->{RaiseError} = 0;
+$dbh->{PrintError} = 0;
+
+my ($ver) = check_schema();
+#print "$ver\n";
+if($ver == 0) {
+ print "Creating tables...\n";
+ do_sql_file("sql/services.sql");
+ upgrade_schema(0);
+} elsif($ver) {
+ upgrade_schema($ver);
+}
+
+print "Updating chanperm...\n";
+
+my $add_perm = $dbh->prepare("INSERT IGNORE INTO chanperm SET name=?, level=?, max=?");
+my $del_perm = $dbh->prepare("DELETE FROM chanperm WHERE name=?");
+
+my @perms = (
+ ['Join', 0, 1],
+ ['AccList', 1, 0],
+ ['AccChange', 5, 0],
+ ['AKICK', 5, 0],
+ ['AKickList', 3, 0],
+ ['AKickEnforce', 5, 0],
+ ['SET', 6, 0],
+ ['BAN', 4, 0],
+ ['CLEAR', 6, 0],
+ ['GETKEY', 4, 0],
+ ['INFO', 0, 0],
+ ['KICK', 4, 0],
+ ['LEVELS', 6, 7],
+ ['LevelsList', 3, 7],
+ ['INVITE', 4, 0],
+ ['InviteSelf', 1, 0],
+ ['TOPIC', 5, 0],
+ ['UnbanSelf', 2, 0],
+ ['UNBAN', 4, 0],
+ ['VOICE', 2, 0],
+ ['HALFOP', 3, 0],
+ ['OP', 4, 0],
+ ['ADMIN', 5, 0],
+ ['OWNER', 6, 0],
+ ['Memo', 5, 0],
+ ['BadWords', 5, 0],
+ ['Greet', 1, 0],
+ ['NoKick', 4, 0],
+ ['BotSay', 5, 0],
+ ['BotAssign', 6, 0],
+ ['SetTopic', 0, 0],
+ ['WELCOME', 6, 0],
+ ['DICE', 1, 0],
+ ['UPDOWN', 1, 0],
+ ['MemoAccChange', 8, 0],
+ ['MODE', 6, 0],
+ ['COPY', 7, 0],
+);
+
+my @noperms = ();
+
+foreach my $p (@perms) {
+ $add_perm->execute($p->[0], $p->[1], $p->[2]);
+}
+
+foreach my $p (@noperms) {
+ $del_perm->execute($p);
+}
+
+hash_all_passwords();
+
+print "Database setup complete!\n";
+
+END:
+$backup_file and print "\nNOTE: To restore your backup, use this command:\n ./db-setup.pl --restore $backup_file\n";
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => dirname(abs_path($0)),
+ );
+ require constant; import constant(\%constants);
+}
+chdir PREFIX;
+use lib PREFIX, "@{[PREFIX]}/CPAN";
+
+use SrSv::Conf 'sql';
+
+$dbh = DBI->connect('DBI:mysql:'.$sql_conf{'mysql-db'}, $sql_conf{'mysql-user'}, $sql_conf{'mysql-pass'},
+ { AutoCommit => 1, RaiseError => 1 });
+
+$get_root_nick = $dbh->prepare("SELECT nickreg.nick FROM nickalias,nickreg WHERE nickalias.nrid=nickreg.id AND alias=?");
+$del_svsop = $dbh->prepare("DELETE FROM svsop USING svsop, nickreg WHERE svsop.nrid=nickreg.id AND nickreg.nick=?");
+
+$get_root_nick->execute($ARGV[0]);
+my ($root) = $get_root_nick->fetchrow_array;
+$get_root_nick->finish;
+
+unless($root) {
+ print "That nick does not exist.\n";
+ exit;
+}
+
+$del_svsop->execute($root);
+$del_svsop->finish;
+
+print "$root has been stripped of all rank.\n";
--- /dev/null
+%BAdminServ%B allows services administrators or higher
+to list, modify, or look up users on the staff lists.
+
+Commands:
+ SVSOP Modify Services Operator
+ WHOIS Check rank of an individual
+ STAFF List all Services Ops
--- /dev/null
+%BAdminServ STAFF%B lists all services staff-members, in rank
+order.
+
+Syntax: %BSTAFF%B
--- /dev/null
+%BAdminServ SVSOP%B modifies the rank of a user and lists
+the services operators.
+
+Syntax: %BSVSOP%B <%UADD|DEL|LIST%U> %Unick%U <%UH|O|A|R%U>
+
+Services Access:
+ H HelpOp
+ O [Services] Operator
+ A [Services] Admin
+ R Services Root
--- /dev/null
+%BAdminServ WHOIS%B displays the services rank of a given user.
+
+Syntax: %BWHOIS%B %Unick%U
--- /dev/null
+Commands:
+ JOIN Force bot to join a channel.
+ PART Force bot to leave a channel.
+ SAY Make bot say a message.
+ ACT Make bot do an action.
--- /dev/null
+%BBotServ%B allows you to control services bots.
+
+Commands:
+ ASSIGN Assign bot to channel
+ UNASSIGN Remove bot from channel
+ LIST List available bots
+ ADD Create a new bot
+ DEL Delete a bot
+ SAY Make bot say a message
+ ACT Make bot do an action
+ SET Set flags on a bot
+
+For more help on a specific command, type: %B/bs help%B %Ucommand%U
--- /dev/null
+%BBotServ ACT%B allows you to make a bot perform an action in a channel.
+
+Syntax: %BACT%B %U#channel%U <%Uaction%U>
--- /dev/null
+%BBotServ ADD%B allows you to create a new services bot.
+
+Syntax: %BADD%B <%Unick%U> <%Uident%U> <%Uvhost%U> <%Urealname%U>
--- /dev/null
+%BBotServ ASSIGN%B allows you to assign a bot to a channel. Once assigned,
+the bot will join the channel and accept commands.
+
+Syntax: %BASSIGN%B %U#channel%U <%Ubot%U>
--- /dev/null
+%BBotServ DEL%B allows you to delete a services bot.
+
+Syntax: %BDEL%B %Ubot%U
--- /dev/null
+%BBotServ LIST%B allows you to view a list of all available services bots.
+
+Syntax: %BLIST%B
--- /dev/null
+%BBotServ SAY%B allows you to make a bot send a message to a channel.
+
+Syntax: %BSAY%B %U#channel%U <%Umessage%U>
--- /dev/null
+%BBotServ SET%B sets flags on bots.
+
+ PRIVATE - defaults to on. Set it off to make a bot public.
+ DEAF - Sets a bot to have umode +d, thus will not receive
+ channel messages. Mostly useful to reduce load.
+ Deaf bots will not be able to be used for
+ any kind of badword kicking.
+
+Syntax: %BSET%B %Ubot%U <%Uflag%U> <%UON/OFF%U>
--- /dev/null
+%BBotServ UNASSIGN%B allows you to remove a previously assigned bot
+from a channel.
+
+Syntax: %BUNASSIGN%B %U#channel%U
--- /dev/null
+Commands:
+ !up Gives you the highest channel status you are allowed.
+ !down Removes all channel status.
+ !invite Invites a user to the channel.
+ !ban Bans a user or mask from the channel.
+ !banlist Lists all bans in the channel, suitable for using the
+ numbers with !unban
+ !qban Places a quiet ban on the user in the channel.
+ !nban Places a nick-change ban on the user in the channel.
+ !kick Kicks a user from the channel.
+ !kickban Kicks and bans a user from the channel.
+ !kickmask Kicks users matching a mask from the channel.
+ !kickbanmask Kicks and bans users matching a mask from the channel.
+ !unban Unbans a user from the channel.
+ !calc Performs a mathematical calculation.
+ !seen Shows how long it has been since a user identified to a nick.
+ !dice Rolls dice, !d 2d4 rolls 2 4 sided dice.
+ !mode Sets modes in a channel.
+ !resync Gives everyone the precise chan-ops they're supposed to have.
+ !topic Sets the topic of the channel.
+
+ !abbreviations Shows all short command aliases.
+ !abbrev
+ !abbrevs
+
+Commands to set channel status:
+ !voice !halfop !op !admin
+ !devoice !dehalfop !deop !deadmin
--- /dev/null
+Commands:
+ !b !ban
+ !k !kick
+ !kb !kickban
+ !kbm !kickbanmask
+ !km !kickmask
+ !kbmask !kickbanmask
+ !d !dice
+ !m !mode
+ !blist !banlist
+ !t !topic
--- /dev/null
+%BChanServ%B allows you to register and control various aspects of
+channels. ChanServ can prevent malicious users from "taking
+over" channels by limiting who is allowed channel operator
+priviliges.
+
+Commands:
+ REGISTER Register a channel
+ SET Change various channel configuration settings
+ AKICK Maintain the channel AutoKick list
+ LEVELS Alter the required access level for commands
+ INFO Information about a channel
+ DROP Drop a registered channel
+ MODE Change channel modes.
+
+Commands to manipulate access lists:
+ CF SOP AOP HOP VOP UOP AUTH
+
+Commands to change or check channel status:
+ VOICE OP HALFOP PROTECT UP
+ DEVOICE DEOP DEHALFOP DEPROTECT DOWN
+ WHY COUNT ALIST RESYNC
+
+Other available commands:
+ DICE INVITE GETKEY CLOSE
+ CLEAR WELCOME DRONE KICKMASK
+ KICK KICKBAN KICKMASK KICKBANMASK
+ TEMPBAN MLOCK JOIN COPY
+ BANLIST TOPIC TOPICAPPEND
+
+Note that channels will be dropped after 21 days of inactivity.
+
+For more help on a specific command, type: %B/cs help%B %Ucommand%U
--- /dev/null
+%BChanServ ADMIN%B allows you to set channel-admin mode on
+either yourself or on other people in a channel.
+
+Syntax: %BADMIN%B %U#channel%U [%Unick%U [%Unick%U ...]]
+ %BADMIN%B %U#channel%U [%Uchannel%U [%Uchannel%U]]
--- /dev/null
+%BChanServ AKICK%B maintains the AutoKick list for a channel.
+If a user on the AutoKick list attempts to join the channel,
+ChanServ will ban that user from the channel, then kick the user.
+
+Syntax: %BAKICK%B %U#channel%U %BADD%B <%Unick/mask%U> [%Ureason%U]
+ %BAKICK%B %U#channel%U %BDEL%B <%Unick/mask/list%U>
+ %BAKICK%B %U#channel%U %BLIST%B
+
+The %BAKICK ADD%B command adds the given nick or hostmask to
+the AutoKick list.
+#If a %Ureason%U is given with the
+#command, that reason will be used when the user is kicked;
+#if not, the default reason is "You have been banned from the
+#channel".
+
+The %BAKICK DEL%B command removes the given nick, mask or
+sequence of numbered-entries from the AutoKick list. It does
+not, however, remove any bans placed by an AutoKick; those must
+be removed manually.
+
+The %BAKICK LIST%B command displays the AutoKick list.
+#or
+#optionally only those AutoKick entries which match the given
+#mask.
+
+The reason is used when kicking and is visible in AKICK LIST. If
+the reason contains a '|' character everything after it does not
+appear in bans placed by an AutoKick; but does appear in AKICK
+LIST.
--- /dev/null
+%BChanServ ALIST%B displays a full listing of all users,
+optionally filtered, that have access to a channel.
+
+Syntax: %BALIST%B %U#channel%U [%Umask%U]
--- /dev/null
+%BChanServ AOP%B maintains the auto-op list for a channel.
+Users on this list are given op status upon joining
+the channel.
+
+Syntax: %BAOP%B %U#channel%U %BADD%B <%Unick%U>
+ %BAOP%B %U#channel%U %BDEL%B <%Unick%U>
+ %BAOP%B %U#channel%U %BLIST%B [%Umask%U]
+ %BAOP%B %U#channel%U %BWIPE%B
+
+The %BAOP ADD%B command adds the given nickname to the list.
+If the target has SET AUTH on, a demotions is handled by
+deleting the target's access, so they may accept the demotion,
+or no access at all.
+
+The %BAOP DEL%B command removes the given nick from the list.
+
+The %BAOP LIST%B command displays the list.
+if a mask is given, only those entries matching the mask are
+displayed.
+
+The %BAOP WIPE%B command removes all entries from the list.
--- /dev/null
+%BChanServ AUTH%B allows channel SOps to delete old/stale
+entries from the pending access list.
+
+Syntax: %BAUTH%B %U#channel%U <%BLIST|DELETE%B> [%Unumber|name%U]
+
+Examples:
+/msg ChanServ AUTH #SurrealChat LIST
+/msg ChanServ AUTH #SurrealChat DELETE Alucard
+/msg ChanServ AUTH #SurrealChat DELETE 3
--- /dev/null
+%BChanServ BAN%B Tells ChanServ to set a ban on a person or
+mask. It can also remove bans, if you prefix the ban with a -
+
+Syntax: %BBAN%B %U#channel%U <%Bnick|mask%B>
+
+By default limited to %BHOP%B
--- /dev/null
+%BChanServ BANLIST%B asks ChanServ for the list of bans in
+a channel.
+
+Syntax: %BBANLIST%B %U#channel%U
--- /dev/null
+%BChanServ CF%B maintains the cofounder list for a channel.
+Users on this list are allowed to do anything the founder can do.
+
+Syntax: %BCF%B %U#channel%U %BADD%B <%Unick%U>
+ %BCF%B %U#channel%U %BDEL%B <%Unick%U>
+ %BCF%B %U#channel%U %BLIST%B [%Umask%U]
+ %BCF%B %U#channel%U %BWIPE%B
+
+The %BCF ADD%B command adds the given nickname to the list.
+If the target has SET AUTH on, a demotions is handled by
+deleting the target's access, so they may accept the demotion,
+or no access at all.
+
+The %BCF DEL%B command removes the given nick from the list.
+
+The %BCF LIST%B command displays the list.
+if a mask is given, only those entries matching the mask are
+displayed.
+
+The %BCF WIPE%B command removes all entries from the list.
--- /dev/null
+%BChanServ CLEAR%B allows you to un-set all channel modes,
+remove all channel status, kick all users, or
+clear the ban list from a channel.
+
+Syntax: %BCLEAR%B %U#channel%U %BMODES%B [%Ureason%U]
+ %BCLEAR%B %U#channel%U %BOPS%B [%Ureason%U]
+ %BCLEAR%B %U#channel%U %BUSERS%B [%Ureason%U]
+ %BCLEAR%B %U#channel%U %BBANS%B [%Ureason%U]
+
+The %BCLEAR MODES%B command removes all channel modes.
+
+The %BCLEAR OPS%B command removes all status from all users
+in a channel.
+
+The %BCLEAR USERS%B command kicks all users from a channel.
+
+The %BCLEAR BANS%B command clears the ban list in a channel.
--- /dev/null
+%BChanServ CLOSE%B clears all users, bans *!*@*, and
+closes the channel down permanently. This process is not
+currently reversible, the channel must be dropped to be
+re-opened.
+
+The founder is unchanged, and the oper who closes the
+channel becomes successor, in case the founder nick is
+dropped.
+
+Syntax: %BCLOSE%B %U#channel%U <%Ureason%U>
+
+Requires SERVOP.
--- /dev/null
+%BChanServ COPY%B copies channel properties from one channel
+to another.
+
+* If #channel2 is not registered, you must be op in
+ #channel2.
+* You must have permission (LEVELS %BCOPY%B) in #channel1 in
+ order to copy to #channel2.
+* If #channel2 is already registered, you must also have
+ permission to copy to it.
+* If no type is specified, type is assumed to be All
+
+Available properties are:
+* All
+ Creates a new #channel2 from #channel1. #channel2 cannot
+ be registered. You must be opped on #channel2.
+* AKick
+* Access
+ May only copy one particular xOp/rank list.
+* LEVELS
+
+Syntax: %BCOPY%B %U#chan1%U [%Utype [rank]%U] %U#chan2%%U
+
+Examples:
+ COPY #chan1 #chan2
+ COPY #chan1 akick #chan2
+ COPY #chan1 access #chan2
+ COPY #chan1 access aop #chan2
--- /dev/null
+%BChanServ COUNT%B displays the number of users in each
+channel access list.
+
+Syntax: %BCOUNT%B %U#channel%U
--- /dev/null
+%BChanServ DOWN%B has two syntaxes.
+
+First form gives you the highest channel op you are allowed
+in the channels you specify. If you specify no channels, all
+channels will be affected.
+
+Second form removes all channel ops from the nick[s] in the
+channel you specify, if you have sufficient rank.
+
+Syntax: %BDOWN%B [%Uchannel%U [%Uchannel%U ...]]
+Syntax: %BDOWN%B %Uchannel%U %Unick%U [[%Unick%U] ...]
--- /dev/null
+%BChanServ DRONE%B is like ChanServ CLOSE but instead of
+using kick it uses G:line or GZ:line.
+
+For more information, see ChanServ CLOSE.
+
+Syntax: %BDRONE%B %U#channel%U <%Ureason%U>
+
+Requires SERVOP.
--- /dev/null
+%BChanServ DROP%B unregisters the named channel. Can only
+be used by the channel founder.
+
+Syntax: %BDROP%B %U#channel%U
--- /dev/null
+%BChanServ GETKEY%B displays a channel's key (+k). If a channel has
+a key, you must provide the key when joining the channel.
+
+Syntax: %BGETKEY%B %U#channel%U
--- /dev/null
+%BChanServ HALFOP%B allows you to set halfop mode on either
+yourself or on other people in a channel.
+
+Syntax: %BHALFOP%B %U#channel%U [%Unick%U [%Unick%U ...]]
+ %BHALFOP%B %U#channel%U [%Uchannel%U [%Uchannel%U]]
--- /dev/null
+%BChanServ HOP%B maintains the auto-hop list for a channel.
+Users on this list are given half-op status upon joining
+the channel.
+
+Syntax: %BHOP%B %U#channel%U %BADD%B <%Unick%U>
+ %BHOP%B %U#channel%U %BDEL%B <%Unick%U>
+ %BHOP%B %U#channel%U %BLIST%B [%Umask%U]
+ %BHOP%B %U#channel%U %BWIPE%B
+
+The %BHOP ADD%B command adds the given nickname to the list.
+If the target has SET AUTH on, a demotions is handled by
+deleting the target's access, so they may accept the demotion,
+or no access at all.
+
+The %BHOP DEL%B command removes the given nick from the list.
+
+The %BHOP LIST%B command displays the list.
+if a mask is given, only those entries matching the mask are
+displayed.
+
+The %BHOP WIPE%B command removes all entries from the list.
--- /dev/null
+%BChanServ INFO%B lists information about the named registered channel,
+including its founder, time of registration, last time used,
+description, and mode lock, if any.
+
+Syntax: %BINFO%B %U#channel%U
--- /dev/null
+%BChanServ INVITE%B allows you to invite a user into a channel.
+
+Syntax: %BINVITE%B %U#channel%U [%Unick%U]
+
+If you do not specify a nick, you will be invited.
--- /dev/null
+%BChanServ JOIN%B requests ChanServ to join you to the
+channel. If you have channel access, the bot will also give
+you an invite, to bypass any bans or other restrictive
+channel modes.
+
+If you are not allowed to join the channel, you will not
+join.
+
+Syntax: %BJOIN%B %U#channel%U [%U#channel%U [%U#channel%U]]
--- /dev/null
+%BChanServ KICK%B allows you to kick a user from a channel.
+
+Syntax: %BKICK%B %U#channel%U <%Unick%U> [%Ureason%U]
--- /dev/null
+%BChanServ KICKBAN%B allows you to kick and ban a user from
+a channel.
+
+Syntax: %BKICKBAN%B %U#channel%U <%Unick%U> [%Ureason%U]
--- /dev/null
+%BChanServ KICKBANMASK%B allows you to kickban users matching a
+hostmask from the channel. It does not affect users with
+channel access.
+
+Syntax: %BKICKBANMASK%B %U#channel%U <%Umask%U> [%Ureason%U]
--- /dev/null
+%BChanServ KICKMASK%B allows you to kick users matching a
+hostmask from the channel. It does not affect users with
+channel access.
+
+Syntax: %BKICKMASK%B %U#channel%U <%Umask%U> [%Ureason%U]
--- /dev/null
+%BChanServ LEVELS%B allows you to adjust the minimum access levels
+required to do certain commands.
+
+Syntax: %BLEVELS%B %U#channel%U %BSET%B <%Ucommand%U> <%Ulevel%U>
+ %BLEVELS%B %U#channel%U %BRESET%B <%Ucommand%U>
+ %BLEVELS%B %U#channel%U %BLIST%B
+ %BLEVELS%B %U#channel%U %BCLEAR%B
+
+The %BLEVELS SET%B command sets the required level for a command.
+
+The %BLEVELS RESET%B command sets the level of a command back to
+the default setting.
+
+The %BLEVELS LIST%B command displays a list of possible commands
+and their current level settings.
+
+The %BLEVELS CLEAR%B command sets all levels back to the default
+settings.
+
+For a list of the different LEVELS settings and what they allow, type:
+%B/cs help levels set%B
--- /dev/null
+%U LEVEL: Allows you to:
+ AccChange Modify channel access lists.
+ AccList View channel access lists.
+ AKICK Modify the AKICK list.
+ AKickEnforce Re-check and enforce the akick list.
+ AKickList View the AKICK list.
+ BadWords *
+ BAN Use ChanServ/BotServ to ban users.
+ BotAssign Assign the BotServ bot.
+ BotSay Use BotServ SAY and BotServ ACT.
+ CLEAR Use ChanServ CLEAR commands.
+ DICE Allowed to use the !dice trigger.
+ GETKEY Use ChanServ GETKEY.
+ Greet Will receive a Greeting upon join
+ HALFOP Use ChanServ/BotServ to half-op (+h) users.
+ INFO Use ChanServ INFO.
+ INVITE Use ChanServ/BotServ to invite users.
+ InviteSelf Use ChanServ/BotServ to invite oneself.
+ Join May join the channel.
+ KICK Use ChanServ/BotServ to kick users.
+ LEVELS Modify the LEVELS list.
+ LevelsList View the LEVELS list.
+ Memo Send channel memos.
+ MemoAccChange Will receive memos about Access List Changes
+ NoKick *
+ OP Use ChanServ/BotServ to op (+o) users.
+ PROTECT Use ChanServ/BotServ to protect (+a) users.
+ SET Modify ChanServ settings.
+ SetTopic Use the /topic command to change the topic.
+ TOPIC *
+ UNBAN Unban others
+ UPDOWN Can use UP or DOWN on other people.
+ UnbanSelf Unban self
+ VOICE Use ChanServ/BotServ to voice (+v) users.
+ WELCOME Modify the ChanServ WELCOME list.
+
+* Not yet implemented.
--- /dev/null
+%BChanServ LIST%B Lists all registered channels matching the given mask.
+(Channels with the PRIVATE option set are not listed, of
+course.)
+
+Syntax: %BLIST%B <%Umask%U>
--- /dev/null
+%BChanServ MLOCK%B allows you to lock channel modes either
+on or off.
+
+Syntax: %BMLOCK%B %U#channel%U <%BADD|DEL|SET|RESET%B> %Umodes%U
+
+The %Umodes%U parameter is constructed exactly the same way as
+a %B/MODE%B command; that is, modes preceded by a %B+%B are locked
+on, and modes preceded by a %B-%B are locked off.
+
+%BWarning:%B If you set a mode-locked key, as in the example
+below, you should also restrict who can join the channel.
+(see %B/cs HELP LEVELS SET%B) Otherwise, anyone entering the channel
+when it is empty will be able to see the key!
+
+Examples:
+
+ %BMLOCK%B %U#channel%U %BADD%B %U+QS-M%U
+ Adds +Q, +S and -M to your mlock.
+
+ %BMLOCK%B %U#channel%U %BDEL%B %UQ%U
+ Removes Q from your mlock, it may be +Q or -Q.
+
+ %BMLOCK%B %U#channel%U %BRESET%B
+ Resets the mode lock to default.
+
+ %BMLOCK%B %U#channel%U %BSET%B %U+nt-iklps%U
+ DON'T USE %USET%U. USE %UADD%U OR %UDEL%U.
+ Forces modes n and t on, and modes i, k, l, p, and
+ s off. Mode m (and others) are left free to be either
+ on or off.
+
+ %BMLOCK%B %U#channel%U %BSET%B %U+knst-ilmp%U %Umy-key%U
+ DON'T USE %USET%U. USE %UADD%U OR %UDEL%U.
+ Forces modes k, n, s, and t on, and modes i, l, m,
+ and p off. Also forces the channel key to be
+ "my-key".
+
+ %BMLOCK%B %U#channel%U %BSET%B %U+%U
+ Removes the mode lock; all channel modes are free
+ to be either on or off.
--- /dev/null
+%BChanServ MODE%B does everything that the regular IRCd MODE
+command does, but allows you to do so if you're not currently
+opped in the channel.
+
+Syntax: %BMODE%B %U#channel%U <%U+modes-modes%U> [%Uparams%U]
+
+Example: MODE #Support +tn
+ MODE #Support +ootn hAtbLaDe XYZ
--- /dev/null
+%BChanServ OP%B allows you to set channel op mode on either
+yourself or on other people in a channel.
+
+Syntax: %BOP%B %U#channel%U [%Unick%U [%Unick%U ...]]
+ %BOP%B %U#channel%U [%Uchannel%U [%Uchannel%U]]
--- /dev/null
+%BChanServ REGISTER%B registers a channel in the ChanServ
+database. In order to use this command, you must first be a
+channel operator on the channel you're trying to register.
+
+Syntax: %BREGISTER%B %U#channel%U [%Upassword%U %Udescription%U]
+
+When you register a channel, you are recorded as the
+"Founder" of the channel. The channel founder is allowed to
+change all of the channel settings for the channel; ChanServ
+will also automatically give the founder channel-operator
+privileges when s/he enters the channel.
+
+NOTES:
+
+Channel passwords are no longer used, however, the command
+will still accept a password as a safety feature. The password
+you specify will be discarded. If you want to add a description,
+you must also specify a password.
+
+In order to register a channel, you must have first registered
+your nickname. If you haven't, %B/msg NickServ HELP%B for
+information on how to do so.
--- /dev/null
+%BChanServ RESYNC%B Synchronizes users in the channel with the
+userlist. This means that if the user can normally get ops,
+ChanServ makes sure the user has ops. Otherwise, if the user
+normally gets voice, ChanServ makes sure the user has voice but
+not ops. Otherwise, ChanServ makes sure the user has neither
+voice nor ops.
+
+This is actually implemented via CS CLEAR <#chan> OPS, and a
+CS UP #chan <all users>
+
+Syntax: %BRESYNC%B %U#channel%U [%U#channel%U [%U#channel%U]]
--- /dev/null
+%BChanServ SET%B allows the channel founder to set various
+channel options and other information
+
+Settings:
+ FOUNDER Set the founder for a channel
+ SUCCESSOR Set the successor for a channel
+ UNSUCCESSOR Remove the successor for a channel
+ PASSWORD Set the channel password
+ DESC Set the channel description
+ OPGUARD Stricter control of chanop status
+ SPLITOPS Let anyone keep ops from a netsplit
+ VERBOSE Notify chanops on command usage
+ NEVEROP Make a channel opless
+ WELCOMEINCHAN Puts WELCOME messages into the channel.
+ This flag doesn't do what you think it does.
+ Don't use it.
+ AUTOVOICE Voices everyone who joins the channel.
+ BANTYPE Selects the ban-type to be used for KICKBAN and AKICKs
+ TOPICLOCK Restricts who can change the topic in the channel.
+ NOCLONES Bans people who bring clones into the channel.
+ BANTIME Time until bans are automatically removed.
+Oper only flags:
+ HOLD Prevent channel from expiring
+ FREEZE Suspend access in this channel
+ BOTSTAY Make the bot stay in the channel when empty.
+ LOG Tells LogServ to join and log the channel.
+
+For more help about a specific setting, type:
+%B/cs help set%B %Usetting%U
--- /dev/null
+%BChanServ SET BANTIME%B sets the default ban time for /cs (kick)ban and /cs tempban.
+Default is 0 (permanent unless manually removed)
+Examples:
+/cs set #pokemonlake bantime +24h
+/cs set #pokemondeluge bantime +12h
+Syntax: %BSET%B %U#channel%U %BBANTIME%B +<%Utime%U>
--- /dev/null
+%BChanServ SET BANTYPE%B determines the kind of ban that
+ChanServ will use for kickbans and akicks.
+Default is 2.
+
+ 0 - *!user@host.domain
+ 1 - *!*user@host.domain
+ 2 - *!*@host.domain
+ 3 - *!*user@*.domain
+ 4 - *!*@*.domain
+ 5 - nick!user@host.domain
+ 6 - nick!*user@host.domain
+ 7 - nick!*@host.domain
+ 8 - nick!*user@*.domain
+ 9 - nick!*@*.domain
+ 10 - cross btwn 2 and 3, depending on if is a java-abcd1 ident or not
+
+Syntax: %BSET%B %U#channel%U %BBANTYPE%B <%Unumber%U>
--- /dev/null
+%BChanServ SET DESC%B sets the description for the channel,
+which can be seen with the %BChanServ INFO%B command.
+
+Syntax: %BSET%B %U#channel%U %BDESC%B <%Udescription%U>
--- /dev/null
+%BChanServ SET FOUNDER%B changes the founder of a channel.
+You must be the current founder of the channel, and the new
+founder must have a registered nick.
+
+Syntax: %BSET%B %U#channel%U %BFOUNDER%B <%Unick%U>
+
+Once you have used this command, you will be automatically
+moved to the channel's co-founder list; you may then remove
+yourself or demote yourself to any lower rank.
--- /dev/null
+%BChanServ SET FREEZE%B sets whether the given channel
+will be suspended, preventing users in that channel
+from being granted their access.
+
+Syntax: %BSET%B %U#channel%U %BFREEZE%B <%UON/OFF%U>
+
+Requires SERVOP.
--- /dev/null
+%BChanServ SET HOLD%B sets whether the given channel will
+expire. Setting this to ON prevents the channel from
+expiring.
+
+Syntax: %BSET%B %U#channel%U %BHOLD%B <%UON/OFF%U>
+
+Requires SERVOP.
--- /dev/null
+%BChanServ SET NEVEROP%B Prevents services from opping users
+in the channel. Users may still use the UP command to gain
+chanop.
+
+Syntax: %BSET%B %U#channel%U %BNEVEROP%B <%UON/OFF%U>
--- /dev/null
+%BChanServ SET NOCLONES%B Kicks and bans users who bring clones (multiple connections) to a channel.
+Users in the channel's access lists are excempt.
+
+Syntax: %BSET%B %U#channel%U %BNOCLONES%B <%UON/OFF%U>
--- /dev/null
+%BChanServ SET OPGUARD%B makes ChanServ strictly
+control channel status.
+
+Syntax: %BSET%B %U#channel%U %BOPGUARD%B <%UON/OFF%U>
+
+When OpGuard is set to ON, only people with the
+appropriate permission will be allowed to grant
+channel status to other users.
+
+Note: This setting will have no effect unless you
+also change the %BLEVELS%B settings for VOICE, HOP,
+OP, and/or PROTECT. See %B/cs help levels%B
--- /dev/null
+%BChanServ SET PASSWORD%B changes the password of a channel.
+
+Syntax: %BSET%B %U#channel%U %BPASSWORD%B <%Upassword%U>
+
+Note: Channel passwords cannot be used; this command
+exists only for completeness.
--- /dev/null
+%BChanServ SET SPLITOPS%B allows users that gain ops from
+initial join or a netsplit to keep their ops. This can
+avoid mass-deops in a channel where not everyone is
+identified to NickServ, but may make channel takeovers
+easier.
+
+Syntax: %BSET%B %U#channel%U %BSPLITOPS%B <%UON/OFF%U>
--- /dev/null
+%BChanServ SET SUCCESSOR%B changes the successor of a channel.
+The new successor must have a registered nick.
+
+Syntax: %BSET%B %U#channel%U %BSUCCESSOR%B <%Unick%U>
+
+The channel successor will be made founder in case the original
+founder's nick is expired or dropped. A channel with no
+successor will expire along with the founder's nick.
--- /dev/null
+Syntax: SET #CHANNEL TOPICLOCK <UOP|VOP|AOP|SOP|CFOUNDER|FOUNDER|OFF>
+
+Enables or disables the TOPICLOCK option for a channel.
+When TOPICLOCK is set, ChanServ will not allow the
+channel topic to be changed unless access permits.
--- /dev/null
+%BChanServ SET UNSUCCESSOR%B Removes the successor of a
+channel.
+
+Syntax: %BSET%B %U#channel%U %BUNSUCCESSOR%B
+
+For more information about successors, type:
+%B/cs help set successor%B
--- /dev/null
+%BChanServ SET VERBOSE%B enables various channel notices for
+ChanServ and BotServ commands.
+
+ VOICE/HOP/OP/PROTECT - Set and Unset
+ AKick - Add/Delete/Move/Wipe
+ VOp/HOp/AOp/SOp/CoFounder - Add/Delete/Move/Wipe
+ BotSay - Usage
+
+Syntax: %BSET% %U#channel%U %BVERBOSE%B <%UON/OFF%U>
--- /dev/null
+%BChanServ SET WelcomeInChan%B instructs services to send
+WELCOME messages to the channel when a user joins, rather
+than to the user as a private NOTICE.
+
+This flag probably doesn't do what you think it does.
+Don't use it.
+
+Syntax: %BSET%B %U#channel%U %BWelcomeInChan%B <%UON/OFF%U>
--- /dev/null
+%BChanServ SOP%B maintains the super-op list for a channel.
+
+Syntax: %BSOP%B %U#channel%U %BADD%B <%Unick%U>
+ %BSOP%B %U#channel%U %BDEL%B <%Unick%U>
+ %BSOP%B %U#channel%U %BLIST%B [%Umask%U]
+ %BSOP%B %U#channel%U %BWIPE%B
+
+The %BSOP ADD%B command adds the given nickname to the list.
+If the target has SET AUTH on, a demotions is handled by
+deleting the target's access, so they may accept the demotion,
+or no access at all.
+
+The %BSOP DEL%B command removes the given nick from the list.
+
+The %BSOP LIST%B command displays the list.
+if a mask is given, only those entries matching the mask are
+displayed.
+
+The %BSOP WIPE%B command removes all entries from the list.
--- /dev/null
+%BChanServ TEMPBAN%B Tells ChanServ to set a ban on a person or
+mask for a set amount of time. The ban will be removed automatically after that time has elapsed.
+
+Syntax: %BTEMPBAN%B %U#channel%U %B<nick|mask>%B <%B+TIME%B>
+
+Examples: TEMPBAN #pokemoncrater erry +1d Enough already!
+TEMPBAN #pokemonlake mario121 Marcus +7d
+
+By default limited to %BHOP%B
--- /dev/null
+%BChanServ TOPIC%B sets, or unsets, the current topic of the channel.
+To unset the topic, use NONE as the message.
+
+Syntax: %BTOPIC%B %U#channel%U <message|NONE>
--- /dev/null
+%BChanServ TOPICAPPEND%B appends a phrase to the current topic, or sets the topic if no topic is set yet.
+
+Syntax: %BTOPICAPPEND%B %U#channel%U <message>
+Examples: /cs TOPICAPPEND #erry COOKIES!
+-!- Eustace has changed the topic of #erry to: SLINKIES | COOKIES!
--- /dev/null
+%BChanServ TOPICAPPEND%B prepends a phrase to the current topic, or sets the topic if no topic is set yet.
+
+Syntax: %BTOPICPREPEND%B %U#channel%U <message>
+Examples: /cs TOPICPREPEND #erry COLORSS!!!
+-!- Eustace has changed the topic of #erry to: COLORSS!!! | SLINKIES | COOKIES!
--- /dev/null
+%BChanServ UNBAN%B Tells ChanServ to remove all bans
+preventing you or another person from entering the given
+channel, or remove particular ban-masks.
+
+Syntax: %BUNBAN%B %U#channel%U [%Unick|mask%U]
+
+By default limited to %BAOP%B
+
+To unban all, use /cs clear #channel bans
--- /dev/null
+%BChanServ UOP%B maintains the user list for a channel.
+
+Syntax: %BUOP%B %U#channel%U %BADD%B <%Unick%U>
+ %BUOP%B %U#channel%U %BDEL%B <%Unick%U>
+ %BUOP%B %U#channel%U %BLIST%B [%Umask%U]
+ %BUOP%B %U#channel%U %BWIPE%B
+
+The %BUOP ADD%B command adds the given nickname to the list.
+If the target has SET AUTH on, a demotions is handled by
+deleting the target's access, so they may accept the demotion,
+or no access at all.
+
+The %BUOP DEL%B command removes the given nick from the list.
+
+The %BUOP LIST%B command displays the list.
+if a mask is given, only those entries matching the mask are
+displayed.
+
+The %BUOP WIPE%B command removes all entries from the list.
--- /dev/null
+%BChanServ UP%B has two syntaxes.
+
+First form gives you the highest channel ops you are allowed
+in the channels you specify. If you specify no channels, all
+channels will be affected.
+
+Second form gives the highest channel ops allowed to the
+nick[s] in the channel you specify.
+
+Syntax: %BUP%B [%Uchannel%U [%Uchannel%U ...]]
+Syntax: %BUP%B %Uchannel%U %Unick%U [[%Unick%U] ...]
--- /dev/null
+%BChanServ VOICE%B allows you to set channel-voice mode on either
+yourself or on other people in a channel.
+
+Syntax: %BVOICE%B %U#channel%U [%Unick%U [%Unick%U ...]]
+ %BVOICE%B %U#channel%U [%Uchannel%U [%Uchannel%U]]
--- /dev/null
+%BChanServ VOP%B maintains the auto-voice list for a channel.
+Users on this list are given voice status upon joining
+the channel.
+
+Syntax: %BVOP%B %U#channel%U %BADD%B <%Unick%U>
+ %BVOP%B %U#channel%U %BDEL%B <%Unick%U>
+ %BVOP%B %U#channel%U %BLIST%B [%Umask%U]
+ %BVOP%B %U#channel%U %BWIPE%B
+
+The %BVOP ADD%B command adds the given nickname to the list.
+If the target has SET AUTH on, a demotions is handled by
+deleting the target's access, so they may accept the demotion,
+or no access at all.
+
+The %BVOP DEL%B command removes the given nick from the list.
+
+The %BVOP LIST%B command displays the list.
+if a mask is given, only those entries matching the mask are
+displayed.
+
+The %BVOP WIPE%B command removes all entries from the list.
--- /dev/null
+%BChanServ WELCOME%B allows you to maintain the channel welcome
+list. The contents of this list will be sent to every user who
+joins your channel.
+
+Syntax: %BWELCOME%B %U#channel%U %BADD%B <%Umessage%U>
+ %BWELCOME%B %U#channel%U %BDEL%B <%Unumber%U>
+ %BWELCOME%B %U#channel%U %BLIST%B
+
+The %BWELCOME ADD%B command adds a message to the welcome list.
+
+The %BWELCOME DEL%B command removes a message from the list.
+
+The %BWELCOME LIST%B command displays the contents of the list.
--- /dev/null
+%BChanServ WHY%B tells what status a user has in a channel.
+
+Syntax: %BWHY%B %U#channel%U [%Unick%U [%Unick%U ...]]
--- /dev/null
+Commands:
+ RAW Send a command in the raw. Must be Server Protocol Format.
+ Requires Services Rank: Services Root or IRCd Rank: NetAdmin.
+ LSMOD Lists all modules loaded.
+ SHUTDOWN Shuts down the services system.
+ Requires Services Rank: Services Admin or IRCd Rank: Server Admin.
--- /dev/null
+%BHostServ%B allows IRC Operators to change vhosts and add auto
+hosting for a registered nick
+
+%BCommands:
+ SETHOST Add or change vHost for a registered nick.
+ DEL Delete vHost from a nick
+ LIST Show nick list of vHosts
+ ON Activate your vHost
+ OFF Unset umode xt to disable your vHost.
--- /dev/null
+%BHostServ DEL%B deletes a vHost from a registered nick.
+
+Syntax: %BDEL%B %Unick%U
--- /dev/null
+%BHostServ LIST%B displays a list of vHosts matching a mask.
+
+Syntax: %BLIST%B %Umask%U
--- /dev/null
+%BHostServ OFF%B resets your vHost to your cloakhost.
+
+Syntax: %BOFF
--- /dev/null
+%BHostServ ON%B activates the vHost currently assigned to the
+nick in use. When you use this command any user who performs a
+whois on you will see the vHost instead of your real host.
+
+Syntax: %BON
--- /dev/null
+%BHostServ SETHOST%B sets the vHost for the given nick to that
+of the given hostmask. If your IRCD supports vIdents, then
+using SET <nick> <ident>@<hostmask> set idents for users as well
+as vhosts.
+
+Syntax: %BSET%B %Unick%U <%Uvhost%U>
--- /dev/null
+%BMemoServ%B is a utility allowing IRC users to send short
+messages to other IRC users, whether they are online at
+the time or not. Both sender and recipient must have
+their nicknames registered with %BNickServ%B in order to
+send a memo.
+
+Commands:
+ SEND Send a memo to a nick/channel
+ CSEND Send a channel memo to higher access levels
+ LIST List all of your memos
+ READ Read a memo
+ DEL Delete a memo
+ IGNORE Block memos coming from a specific person
+
+For more help on a specific command, type: %B/ms help%B %Ucommand%U
--- /dev/null
+Syntax: \ 2CSEND #<chan> [\1fAOP\1f|\1fSOP\1f|\1fCF\1f] <message>\ 2
+
+This command will send a channel memo to only the
+higher channel access users.
+Selections: AOP = Will send to all AOP/SOP/CF
+ SOP = Will only send to SOP and Co-Founders
+ CF = Will only send to Channel Founders
+* Note: The Founder receives memos from any selection.
+ Also, selecting ALL or AVOICE will just send
+ a general channel memo.
+
+EX: /MSG MemoServ CSEND #mychan SOP hello all
+
+The Above example will send "hello all" to the
+channel's Super-Ops, Co-Founders and Founder.
--- /dev/null
+%BMemoServ CSEND%B allows you to send a channel memo
+to users of a certain rank or higher.
+
+Syntax: %BCSEND%B %U#channel%U <%Urank%U> <%Umessage%U>
+
+Valid ranks include: UOP, VOP, HOP, AOP, SOP, CF, FOUNDER
--- /dev/null
+%BMemoServ DEL%B deletes a memo, a series of memos, or all memos.
+
+Syntax: %BDEL%B <%Unumber%U>
+ %BDEL%B <%Unumber1-number2%U>
+ %BDEL%B <%Unumber1..number2%U>
+ %BDEL ALL%B
--- /dev/null
+%BMemoServ IGNORE%B gives you the ability to manage a
+permanent MemoServ ignore list with this command. All
+nicknames added to your ignore list must be registered. If a
+nickname on your ignore list tries to send you a memo, the
+ignored person will be notified that they are on your ignore
+list and you do not wish to receive any memos from them.
+
+Syntax: %BIGNORE%B <%UADD|DEL|LIST%U> [<%Unick%U>]
+
+This is a good way to avoid memos from people who spam you.
+They can get around an ignore by registering a different
+nickname, but if people do so just to continue spamming, you
+can report them to networks staff.
+
+MemoServ abuse is uncommon since it requires that the person
+register a nick to do it, and thus leaves a record of who
+was causing problems.
+
+Examples:
+/msg memoserv ignore add benny
+/msg memoserv ignore del Dainera
+/msg memoserv ignore list
--- /dev/null
+\ 2MemoServ\ 2 is a utility allowing IRC users to send short
+messages to other IRC users, whether they are online at
+the time or not. Both sender and recipient must have
+their nicknames registered with \ 2NickServ\ 2 in order to
+send a memo.
+
+MemoServ's commands include:
+
+Core Commands:
+
+SEND - Send a memo to a nick/channel
+CSEND - Send a channel memo to higher access levels
+LIST - List all of your memos
+READ - Read a memo
+DEL - Set Delete flag for a memo (or all memos)
+UNDEL - Remove the delete flag for a memo (or all memos)
+UNSEND - Retrieve a memo sent to a user
+PURGE - Erase all marked memos as deleted
+FORWARD - Have memos forwarded to another registered nick
+MARK - MARK a memo that you do not want to expire
+UNMARK - UNMARK a memo that you do not want to expire
+NEWS - Recent news and information about network
+SET - Set options related to memos
+
+Type \ 2/msg MemoServ HELP \1fcommand\1f\ 2 for help on any of the
+above commands.
--- /dev/null
+%BMemoServ LIST%B lists the memos you currently have. Unread memos
+are displayed in bold.
+
+Syntax: %BLIST%B
--- /dev/null
+%BMemoServ READ%B displays a specified memo that you have
+received.
+
+Syntax: %BREAD <%Unum|LAST%U>
+
+Sends you the text of memo number %Bnum%B, or of the last
+(i.e. most recently received) memo if LAST is given
+instead of a number.
--- /dev/null
+%BMemoServ SEND%B allows you to send a memo to a nick or channel.
+
+Syntax: %BSEND%B <%Unick/#chan%U> <%Umessage%U>
--- /dev/null
+Syntax: \ 2UNSEND \1fnick\1f\ 2
+
+Retrieves the latest memo you sent to
+the person, and deletes it. This feature
+currently only works for nicks, not channels.
--- /dev/null
+%BNickServ%B allows you to register a nickname and prevent others
+from using it.
+
+Commands:
+ REGISTER Register a nickname
+ SET Change settings
+ IDENTIFY Authorize yourself using a password
+ SIDENTIFY Identify and change to that nickname.
+ GIDENTIFY Identify, GHOST, and change to that nickname.
+ GHOST Kill a user who is using your nick
+ RECOVER Recovers/jupes a nick to stop another user from using it.
+ RELEASE Releases your nick from services custody
+ INFO Get information about a nick
+ DROPGROUP Delete a registered nickname and all aliases
+
+ LINK Make an alias of your nick
+ UNLINK Remove an alias
+ DROP Same as UNLINK
+ CHGROOT Change your root nick
+
+Additional Commands:
+ GLIST ALIST WATCH SILENCE ACC SEEN AJOIN LISTEMAIL
+ LOGOUT LIST AUTH AUTHCODE SENDPASS PROFILE
+
+%BNOTICE:%B This service is intended to provide a way for IRC users to
+ensure their identity is not compromised. It is NOT intended to
+facilitate "stealing" of nicknames or other malicious actions. Abuse
+of NickServ will result in, at minimum, loss of the abused nicknames.
+
+For more help on a specific command, type: %B/ns help%B %Ucommand%U
--- /dev/null
+%BNickServ ACC%B allows you to view the current status of a nickname. It
+is intended to be used by scripts.
+
+Syntax: %BACC%B %Unick%U
+
+The codes have the following meanings:
+ 0 The nick is not registered.
+ 1 The nick is registered but not in use.
+ 2 The nick is in use but the user has not identified.
+ 3 The nick is in use and the user has identified.
--- /dev/null
+%BNickServ ACC%B Returns whether the user using the given
+nickname is recognized as the owner of the nickname. The
+response has this format:
+
+ %Bnickname%B %Bacc-code%B
+
+%Bacc-code%B is one of the following:
+
+ 0 - Nickname Unregistered
+ 1 - Registered, Offline
+ 2 - UnIdentified
+ 3 - Identified via password authentication
+ 4 - Identified via access list
+ 5 - Forbidden Nickname
+
+Syntax: %BACC%B %Unickname%U
+
--- /dev/null
+Syntax: %BAJOIN%B [%Unick%U] %BADD%B <%Uchannel%U>
+ %BAJOIN%B [%Unick%U] %BDEL%B <%Uchannel|entry-nr|list%U>
+ %BAJOIN%B [%Unick%U] %BLIST%B [%Umask|list%U]
+ %BAJOIN%B [%Unick%U] %BJOIN%B
+ %BAJOIN%B [%Unick%U] %BCLEAR%B
+ %BAJOIN%B [%Unick%U] %BWIPE%B
+
+Maintains the %BAutoJoin list%B for nick group.
+If a user identifies to his nickname, he will
+automatically join the listed channels.
+
+The %BAJOIN ADD%B command adds the given channel
+to the AutoJoin list.
+
+The %BAJOIN DEL%B command removes the given channel
+from the AutoJoin list. If a list of entry numbers is given,
+those entries are deleted.
+
+The %BAJOIN LIST%B command displays the AutoJoin list.
+If a wildcard mask is given, only those entries matching the
+mask are displayed. If a list of entry numbers is given, only
+those entries are shown.
+
+The %BAJOIN JOIN%B attempts to join you to all of the channels
+in your list.
+NOTE: %BAJOIN%B does not [attempt to] bypass bans, chmode +i,
+or any other such thing.
+
+The %BAJOIN WIPE%B command clears all entries on the
+AutoJoin list.
--- /dev/null
+%BNickServ ALIST%B allows you to view a list of channels where a nick
+has access.
+
+Syntax: %BALIST%B [%Unick%U [%Unick%U ...]]
+
+If you do not specify a nick, your current nick will be used.
--- /dev/null
+%BNickServ AUTH%B is used for reviewing and approving/rejecting
+channel access grants.
+
+ACCEPT - Approve the authorization request and memo the person confirmation.
+APPROVE - Same as accept.
+DECLINE - Decline the authorization request and memo the person
+ that you will not be added to that channel list.
+REJECT - Same as decline
+LIST - List auth requests.
+
+Syntax: AUTH [%Unick%U] <%ULIST|ACCEPT|DECLINE%U> [%Unum|chan%U]
+
+If you do not want to be added to that channel list, use decline or reject.
+Demotions are handled by deleting the target's access, so they may accept
+the demotion, or no access at all.
+
+Other related commands:
+/msg nickserv help set auth
--- /dev/null
+%BNickServ AUTHCODE%B is used for nick registrations when email
+verification is enabled, or for sendpass when password-hashing
+is enabled.
+
+More information on its use should be in the email you receive.
+
+Syntax: %BAUTHCODE%B %Unickname%U <%Ucode%U> [%Unewpassword%U]
--- /dev/null
+%BNickServ CHGROOT%B sets the "root" nickname for your
+nickname group. The root nick is the one that will appear
+in various displays as your main nick.
+
+Syntax: %BCHGROOT%B [%Uoldroot%U] %Unewroot%U
--- /dev/null
+%BNickServ DROP%B allows you to relinquish a previously registered
+nickname.
+
+Syntax: %BDROP%B %Unick%U <%Upassword%U>
--- /dev/null
+%BNickServ DROPGROUP%B allows you to delete a whole group of
+nicks/aliases
+
+Syntax: %BDROPGROUP%B %Unick%U <%Upassword%U>
--- /dev/null
+%BNickServ EMAILREG%B is used for nick registrations when email
+verification is enabled.
+
+More information on its use should be in the email you receive.
+
+Syntax: %BEMAILREG%B %Unickname%U <%Ucode%U>
--- /dev/null
+%BNickServ GHOST%B terminates a "ghost" IRC session using
+your nick. A "ghost" session is one which is not actually
+connected, but which the IRC server believes is still online.
+Typically, this happens when your Internet connection goes down
+while you're on IRC.
+
+Syntax: %BGHOST%B %Unick%U [%Upassword%U]
+#
+#In order to use the GHOST command for a nick, your current
+#address as shown in /WHOIS must be on that nick's access
+#list, or you must supply the correct password for the
+#nickname.
+#
+#This command also identifies you to your nick if you are not
+#already.
--- /dev/null
+%BNickServ GIDENTIFY%B is similar to the IDENTIFY command. The
+difference is GIDENITFY changes your nickname while
+identifying, and will use GHOST if the target nick is
+currently online.
+
+Syntax: %BGIDENTIFY%B %Unick%U <%Upassword%U>
+
+Examples:
+ GIDENTIFY Soulja soulseeker
+ GID bob thebuilder
--- /dev/null
+%BNickServ GLIST%B allows you to view a list of linked nicks.
+
+Syntax: %BGLIST%B [%Unick%U [%Unick%U ...]]
+
+If you do not specify a nick, your current nick will be used.
+
+%BLINKS%B is an alias for %BGLIST%B.
--- /dev/null
+link.txt
\ No newline at end of file
--- /dev/null
+%BNickServ IDENTIFY%B tells NickServ that you are really
+the owner of this nick. Many commands require you to
+authenticate yourself with this command before you use them.
+The password should be the same one you sent with the
+%BREGISTER%B command.
+
+Syntax: %BIDENTIFY%B [%Unick%U] <%Upassword%U>
+
+Examples:
+ IDENTIFY n00b
+ IDENTIFY Soulja soulseeker
+ ID bob thebuilder
+
+You MUST specifiy the nick if identifying to a nick you're
+not using right now, or for nicks with %BHIGH%B or %BKILL%B
+protection.
--- /dev/null
+%BNickServ INFO%B displays information about the given
+nicknames, such as the nick's owner, last seen address and
+time, and nick options.
+
+Syntax: %BINFO%B %Unick%U [%Unick%U ...]
--- /dev/null
+%BNickServ LINK%B links your current nickname to another
+nickname. Linked nicknames share everything from access
+lists and settings to memos.
+
+Syntax: %BLINK%B %Unick%U <%Upassword%U>
+
+This command does NOT support linking two groups together.
+
+%BGROUP%B is an alias for %BLINK%B.
--- /dev/null
+glist.txt
\ No newline at end of file
--- /dev/null
+%BNickServ LIST%B is used by opers to find registered nicks that
+match wildcard patterns.
+
+Syntax: %BLIST%B %Umask%U
+
+Masks are quite flexible, and can be as simple as nick*! or
+ident@*host
--- /dev/null
+%BNickServ LISTEMAIL%B is used by opers to find registered nicks
+whose email addresses match a specified pattern.
+
+Syntax: %BLISTEMAIL%B %Uemail@address.tld%U
--- /dev/null
+%BNickServ LOGOUT%B logs you out of all nicks that you are
+identified. THE USE OF THIS COMMAND IS LOGGED.
+
+Syntax: %BLOGOUT%B
--- /dev/null
+%BNickServ PROFILE%B stores information about you for others
+to read.
+
+Syntax: %BPROFILE READ%B <%Unick%U> [%Unick%U ...]
+ %BPROFILE%B [%Unick%U] %BSET%B %Uitem%U %Udata%U
+ %BPROFILE%B [%Unick%U] %BDEL%B %Uitem%U
+ %BPROFILE%B [%Unick%U] %BWIPE%B
+
+The %BPROFILE READ%B command displays PROFILE data for you
+or for a list of registered nicks.
+
+The %BPROFILE SET%B command adds an entry to your profile.
+
+%BExamples:%B
+ /ns profile set aim blahblah123
+ /ns profile set myspace http://www.myspace.com/you
+ /ns profile set birthday June 9, 1969
+ /ns profile set mood sassy
+
+%BWARNING%B: Don't put private information in your profile.
+There are no restrictions on who can read it.
+
+The %BPROFILE DEL%B command removes an entry from your profile.
+
+The %BPROFILE WIPE%B command deletes your entire profile.
--- /dev/null
+%BNickServ RECOVER%B allows you to get back your nick if
+someone else is using it. It's slightly nicer than GHOST.
+
+NickServ will change the target's nick to a guestnick, and
+jupes the nick for one minute. To use it yourself, use
+%BNS RELEASE%B, then change your nick, OR use %BNS SIDENTIFY%B
+
+Syntax: %BRECOVER%B %Unick%U [%Upassword%U]
+
+This command also identifies you to your nick if you are not
+already. If you are already identified, the password is
+optional.
--- /dev/null
+%BNickServ REGISTER%B allows you to reserve a particular nickname for
+your own use and prove your identity using a password.
+
+Syntax: %BREGISTER%B <%Upassword%U> <%Ue-mail%U>
+
+%BNOTICE:%B The email address is %BNOT%B optional and you are strongly
+discouraged from using a fake address, as this will make it impossible
+to prove your ownership of a nick should you forget your password.
--- /dev/null
+%BNickServ RELEASE%B removes any hold on your nickname. NickServ
+will hold a nickname that is used without authorization for one
+minute; this command releases it sooner.
+
+Syntax: %BRELEASE%B %Unick%U [%Upassword%U]
--- /dev/null
+%BNickServ SEEN%B displays how long it has been since a user identified
+to a nick.
+
+Syntax: %BSEEN%B %Unick%U
--- /dev/null
+%BNickServ SENDPASS%B sends the password (or an authentication
+code) to the email-address that the target nick is registered
+with.
+
+As currently implemented, this command is only available to
+Network Staff.
+
+Syntax: %BSENDPASS%B %Utarget%U
--- /dev/null
+%BNickServ SET%B allows you to change the various settings associated
+with your nickname. The following settings are available:
+
+ PROTECT Protect your nick from unauthorized use.
+ PASSWORD Change your password.
+ EMAIL Change your email address.
+ HIDEMAIL Hide your email address from other users.
+ NOMEMO Block memos sent to this nick.
+ NOACC Prevent this nick from being added to channel access lists.
+ NEVEROP Prevent ChanServ from automatically granting you channel
+ operator status.
+ AUTH Prevent others from adding you to channel access lists
+ without authorization from you.
+ VACATION Extend the time your nick will last before expiring.
+ ROOT Change the root nick for your nickgroup.
+ UMODE Set user modes to be added or removed upon identifying
+
+Oper only flags:
+ HOLD Prevent nickname from expiring
+ FREEZE Suspend access to this nickname
+ EMAILREG If enabled, forces user to revalidate their email address.
+ If disabled, force validates their email address.
+
+For more information on a specific option, type:
+%B/msg nickserv help set <option>%B
--- /dev/null
+NickServ SET AUTH enables selective Channel Rank acceptance.
+See HELP NickServ AUTH for more information.
+
+Syntax: %BSET%B [%Unick%U] %BAUTH%B <%UON|OFF%U>
--- /dev/null
+root.txt
\ No newline at end of file
--- /dev/null
+%BNickServ SET EMAIL%B Associates the given E-mail address with
+the nick. This address will be displayed whenever someone
+requests information on the nick with the INFO command.
+
+Syntax: %BSET%B [%Unick%U] %BEMAIL%B <%Uaddress%U>
+
+The %BHIDEMAIL%B command will hide your email from INFO
+requests.
+
+If %BHIDEMAIL%B is given, your email will no longer be hidden
+and will be visible to all in INFO requests.
--- /dev/null
+%BNickServ SET GREET%B sets the message that will be
+displayed when joining a channel that you have sufficient
+access to and has GREET enabled.
+
+Syntax: %BSET%B GREET%B <%UNONE|message%U>
+
+NONE will remove/unset your greet.
--- /dev/null
+%BNickServ SET HIDEMAIL%B hides your email address from users.
+
+Syntax: %BSET%B [%Unick%U] %BHIDEMAIL%B <%UON|OFF%U>
+
+If %BHIDEMAIL%B is disabled, your email will no longer be
+hidden and will be visible in your NickServ INFO listing.
--- /dev/null
+%BNickServ SET HOLD%B sets whether the given nick will
+expire. Setting this to ON prevents the nick from
+expiring.
+
+Syntax: %BSET%B [%Unick%U] %BHOLD%B <%UON/OFF%U>
--- /dev/null
+%BNickServ SET NEVEROP%B Prevents services from giving you
+channel status upon channels. You may still use the UP command
+to gain your status.
+
+Syntax: %BSET%B [%Unick%U] %BNEVEROP%B <%UON|OFF%U>
--- /dev/null
+%BNickServ SET NOACC%B Prevents other people from adding
+you to channel access lists.
+
+Syntax: %BSET%B [%Unick%U] %BNOACC%B <%UON|OFF%U>
--- /dev/null
+%BNickServ SET NOMEMO%B blocks incoming memos for your current
+nick. This does not prevent you from sending memos, it will
+only block receieving memos to you from others.
+
+Syntax: %BSET%B [%Unick%U] %BNOMEMO%B <%UON|OFF%U>
--- /dev/null
+%BNickServ SET PASSWD%B Changes the password used to
+identify you as the nick's owner
+
+Syntax: %BSET%B [%Unick%U] %BPASSWD%B %Upassword%U
--- /dev/null
+%BNickServ SET PROTECT%B allows you to control the extent to which
+your nick will be protected from unauthorized use.
+
+Syntax: %BSET%B [%Unick%U] %BPROTECT%B <%UOFF|ON|HIGH|KILL%U>
+
+With PROTECT OFF, anyone may use your nick without authorization.
+
+With PROTECT ON, users of your nick must identify within
+one minute or their nick will be changed. This is the default.
+
+With PROTECT HIGH, users must identify before using your nick
+or their nick will be changed immediately.
+
+With PROTECT KILL, users must identify before using your nick
+or they will be disconnected from IRC.
--- /dev/null
+%BNickServ SET ROOT%B is an alias for NS CHGROOT.
+
+See NS HELP CHGROOT for more information.
+
--- /dev/null
+%BNickServ SET UMODE%B sets the umodes that NickServ will set
+on you when you identify.
+
+Syntax: %BSET%B [%Unick%U] %BUMODE%B <%U+modes-modes|none%U>
--- /dev/null
+%BNickServ SET VACATION%B extends the time limit on nick
+expiration from %E$services::conf{'nickexpire'}%E days to %E$services::conf{'vacationexpire'}%E days. Your nick must
+be at least %Eint($services::conf{'vacationexpire'}/3)%E days old for this to be available.
+
+The flag is cleared on your next identify, and you will not be
+able to use it again until %Eint($services::conf{'vacationexpire'}/3)%E days have passed.
+
+Syntax: %BSET%B [%Unick%U] %BVACATION%B <%UON|OFF%U>
--- /dev/null
+%BNickServ SIDENTIFY%B is similar to the IDENTIFY command. The
+difference is SIDENITFY changes your nickname while
+identifying.
+It will automatically release an enforced nick, but it will
+not ghost or recover your nick if another user is using it.
+
+Syntax: %BSIDENTIFY%B %Unick%U <%Upassword%U>
+
+Examples:
+ SIDENTIFY n00b
+ SIDENTIFY Soulja soulseeker
+ SID bob thebuilder
+
+Example:
+/msg nickserv sidentify yournick yourpass
+This command is mostly useful if you use HIGH protection on your nickname.
--- /dev/null
+%BNickServ SILENCE%B allows you to view and modify your NickServ silence
+list. Users on your silence list will not be able to send you private
+messages.
+
+Syntax: %BSILENCE ADD%B <%Unick!ident@host%U> [%U+expiry%U] [%Ucomment%U]
+ %BSILENCE ADD%B <%Unick%U> [%U+expiry%U] [%Ucomment%U]
+ %BSILENCE DEL%B <%Unick!ident@host%U>
+ %BSILENCE LIST%B
+
+The %BSILENCE ADD%B command adds a nick or hostmask to your silence list.
+Expiry and comment are both optional.
+
+The %BSILENCE DEL%B command removes a hostmask from your silence list.
+
+The %BSILENCE LIST%B command displays your silence list.
+
+%BExamples:%B
+ /ns silence add erry +24h
+ /ns silence del 3
+ /ns silence add candyland101 +365d
+
+%BCAVEATS:%B You cannot have more than 32 silence entries.
+Use of an appropriate expiration is highly recommended.
--- /dev/null
+%BNickServ UNLINK%B allows you to delete a linked nickname.
+
+Syntax: %BUNLINK%B %Unick%U <%Upassword%U>
--- /dev/null
+%BNickServ WATCH%B allows you to view and modify your NickServ watch list.
+You will be notified when a user on your watch list connects to IRC.
+
+Syntax: %BWATCH ADD%B <%Unick/mask%U>
+ %BWATCH DEL%B <%Unick/mask%U>
+ %BWATCH LIST%B
+
+The %BWATCH ADD%B command adds the specified nick or hostmask to your
+watch list.
+
+The %BWATCH DEL%B command removes the specified nick or hostmask from
+your watch list.
+
+The %BWATCH LIST%B command displays your watch list.
+
+%BCAVEATS:%B You cannot use wildcards in nicks, and you cannot have more
+than 128 watch entries.
--- /dev/null
+%BOperServ%B provides various functions that may be used by
+IRC Operators.
+
+Commands:
+ FJOIN Force a user to join a channel.
+ FPART Force a user to part a channel.
+ UNIDENTIFY Log out a user from all nick identifies.
+ QLINE Maintain services QLINE list.
+ JUPE Introduce a fake server to network.
+ UINFO Get information about a user.
+ NINFO Get information about all users identified to
+ a nick.
+ SVSNICK Change a user's nick.
+ GNICK Change a user's nick to guest with random number.
+ STAFF List services operators.
+ LOGONNEWS Maintain logon news list.
+ EXCEPT Maintain clone exception list.
+ SESSION List the number of clones per host.
+ CHANKILL G:line all users in a channel.
+ REHASH Rehash all servers.
+ LONERS Get users that are in zero channels.
+ KILL KILLs a user normally.
+ SVSKILL KILLs a user with a specified quit message.
+ GLINE Adds and removes G:lines.
+ GZLINE Adds and removes Z:lines.
+ CLONES Lists and/or manipulates clones.
+ Similar to LONERS.
+ MASSKILL Alias for CLONES KILL.
+ KILLNEW List/kill/uinfo/kline newly connected users.
--- /dev/null
+%BOperServ CHANKILL%B adds a G:line for every user in a channel,
+IRCOps excepted.
+
+Syntax: %BCHANKILL%B %U#channel%U <%Ureason%U>
--- /dev/null
+%BOperServ CLONES%B gets the list of clone-users that match a
+specific host, IP, or nickname and optionally:
+
+* retrieves %BUINFO%B,
+* sends a %BMSG%B to the users,
+* %BFJOIN%Bs the users,
+* %BKILL%Bs the users,
+* %BKLINE%Bs the users.
+
+Syntax: %BCLONES%B <%ULIST|UINFO|MSG|FJOIN|KILL|KLINE%U> [%Umsg/reason%U]
+
+ LIST - Lists all users that match.
+ UINFO - Retrieves UINFO for all users that match. %BWARNING%B May flood you off.
+ MSG - Sends a NOTICE from OperServ to the users. Message is not optional. (DUH)
+ FJOIN - Force-Join to a channel.
+ KILL - Kill the users. Reason is optional, but recommended.
+ KLINE - G:Line the users. Reason is optional, but recommended.
--- /dev/null
+%BOperServ EXCEPT%B is used to add clone-limit exceptions.
+
+There are 3 different kinds of exceptions
+SERVER - All users on this server[mask]
+HOSTNAME - All users with this hostmask
+IP - All users in this IP Netblock
+
+The overall syntax isn't hard, just not well documented. Until
+now.
+
+OS EXCEPT SERVER ADD <name> <limit>
+OS EXCEPT SERVER DEL <name>
+OS EXCEPT HOSTNAME ADD <name> <limit>
+OS EXCEPT HOSTNAME DEL <name>
+
+and the only really different one, IP
+OS EXCEPT IP ADD <IP[/mask]> <limit>
+OS EXCEPT IP DEL <IP[/mask]>
+
+Mask is in bits, like CIDR notation.
+127.0.0.1/32 means 127.0.0.1-127.0.0.1
+or say AOL
+172.192.0.0/12 -> 172.192.0.0 - 172.207.255.255
+172.208.0.0/14 -> 172.208.0.0 - 172.211.255.255
+
+Sorry, it doesn't do the alternate CIDR format
+172.192.0.0/255.240.0.0
\ No newline at end of file
--- /dev/null
+%BOperServ FJOIN%B forces a user to join a channel.
+
+Syntax: %BFJOIN%B %Unick%U %U#channel%U
--- /dev/null
+%BOperServ FPART%B forces a user to part a channel.
+
+Syntax: %BFPART%B %Unick%U %U#channel%U
--- /dev/null
+%BOperServ GNICK%B forces a user to have their nick changed to a
+Guest. Commonly used when qlining, or when a user is otherwise
+using a nick they should not.
+
+Syntax: %BGNICK%B %Unick%U
--- /dev/null
+%BOperServ JUPE%B allows you to jupiter a server -- that is, to
+create a fake "server" connected to Services which prevents the
+real server of that name from connecting. The jupe may be
+removed using a standard SQUIT. To be used only in a situation
+where a server is disrupting the network and must be juped.
+
+Syntax: %BJUPE%B %Userver%U %Ureason%U
--- /dev/null
+%BOperServ KILL%B KILLs a user off the network.
+One possible use is to allow helpers to KILL.
+
+Syntax: %BKILL%B %Utarget%U <%Ureason%U>
+
+Example: KILL erry not kool.
--- /dev/null
+%BOperServ KILLNEW%B gets the list of users that connected within a
+certain period of time.
+
+* retrieves %BUINFO%B,
+* sends a %BMSG%B to the users,
+* %BFJOIN%Bs the users,
+* %BKILL%Bs the users,
+* %BKLINE%Bs the users.
+
+Syntax: %BKILLNEW%B <%ULIST|UINFO|MSG|FJOIN|KILL|KLINE%U> [NOTID] +time [%Umsg/reason%U]
+
+ LIST - Lists all users that match.
+ UINFO - Retrieves UINFO for all users that match. %BWARNING%B May flood you off.
+ MSG - Sends a NOTICE from OperServ to the users. Message is not optional. (DUH)
+ FJOIN - Force-Join to a channel.
+ KILL - Kill the users. Reason is optional, but recommended.
+ KLINE - G:Line the users. Reason is optional, but recommended.
+
+Examples:
+
+ KILLNEW LIST NOTID +5m
+ KILLNEW UINFO +30s
+ KILLNEW KILL NOTID +30s
--- /dev/null
+%BOperServ LOGONNEWS%B handles the logonnews system.
+
+There are two lists. one for Users, and one for Opers (not
+finished yet). A news item may be permanent (does not expire) or
+may have a limited life (expires).
+
+Syntax: %BLOGONNEWS ADD%B <%UU|O%U> [%U+expiry%U] <%Umessage%U>
+ %BLOGONNEWS LIST%B <%UU/O%U>
+ %BLOGONNEWS DEL%B <%UU/O%U> <%Unum%U>
--- /dev/null
+%BOperServ LONERS%B gets the list of users in zero channels and
+optionally retrieves %BUINFO%B, sends a %BMSG%B, %BFJOIN%B,
+%BKILL%B, or %BKLINE%B. if you specify %BNOID%B it will only act on
+users that have not identified to any nicks.
+
+Syntax: %BLONERS%B [%ULIST|UINFO|MSG|FJOIN|KILL|KLINE%U] [%UNOTID%U] [%Umsg/reason%U]
+
+If no command is specified, defaults to LIST.
+
+ LIST - Lists all users in zero channels
+ UINFO - Retrieves UINFO for all users in zero channels. %BWARNING%B May flood you off.
+ MSG - Sends a NOTICE from OperServ to the users. Message is not optional. (DUH)
+ FJOIN - Force-Join to a channel. Will obviously make them no longer be in zero channels.
+ KILL - Kill the users. Reason is optional, but recommended.
+ KLINE - G:Line the users. Reason is optional, but recommended.
+
+ NOTID - Only matches if the users are not identified to nicks.
+ May be used with any of the above.
+ Also aliased to NOIDENTIFY and NOID.
--- /dev/null
+%BOperServ NINFO%B calls OS UINFO for all clients identified
+to a nick.
+
+Syntax: %BNINFO%B %Unick%U
--- /dev/null
+%BOperServ QLINE%B prevents a nick or nickmask from being used,
+except by opers and services agents.
+
+Syntax: %BQLINE ADD%B [%U+expiry%U] <%Umask%U> <%Ureason%U>
+ %BQLINE DEL%B <%Umask%U>
+ %BQLINE LIST%B
--- /dev/null
+%BOperServ REHASH%B signals all servers to re-read their configuration
+files.
+
+Syntax: %BREHASH%B [%Utype%U]
--- /dev/null
+%BOperServ SESSION%B displays a list of hosts with more than a
+certain number of clones.
+
+Syntax: %BSESSION%B %Unumber%U
--- /dev/null
+%BOperServ STAFF%B lists all Services Operators.
+
+Syntax: %BSTAFF%B
--- /dev/null
+%BOperServ SVSKILL%B KILLs a user off the network with a custom
+QUIT message.
+
+This command is limited to %BServices Roots%B, as it is
+%Uhighly%U abuseable.
+
+Syntax: %BSVSKILL%B <%Utarget%U> <%Ureason here%U>
+
+Example: SVSKILL Alucard Quit: I am the very model of a modern major general.
--- /dev/null
+%BOperServ SVSNICK%B forcibly changes a user's nick.
+
+Syntax: %BSVSNICK%B <%Uoldnick%U> <%Unewnick%U>
--- /dev/null
+%BOperServ UINFO%B Allows IRC Operators to view additional
+status about a client. IE: Nicks identified, or channels joined
+regardless of modes (+s)
+
+Syntax: %BUINFO%B %Unick%U
--- /dev/null
+%BOperServ UNIDENTIFY%B logs a user out of any nicks they are
+identified to.
+
+Syntax: %BUNIDENTIFY%B %Unick%U
--- /dev/null
+- This is SecurityBot.
+
+- Available Commands:
+- NOTICE nick message: Say something.
+- MSG nick message: Say it again.
+- RAW message: Say it from the heart.
+
+- TOR-UPDATE: Update Tor server list
+
+- KILL nick reason: Commit murder.
+
+- CONF: View configuration.
+- SET name value: Edit configuration.
+- AUTH hostmask: Allow someone to control me.
+- REHASH: Revert configuration.
+- SAVE: Save configuration.
+
+- TSSYNC: Sync all the ircds clocks to services
+- TKL: Manipulate the TKL (G:line & Z:line) list
--- /dev/null
+%BSecurityBot TKL%B is a series of functions to make TKL
+handling easier. Specifically it will help in handling
+G:lines and GZ:lines.
+
+Syntax is as follows:
+
+TKL LIST [(+/- filters) [params]]
+TKL DEL <(+/- filters) <params>>
+
+Filters are case-sensitive.
+
+Filter-parameters may be delimited by // (for regexps) or
+"" (for regexps or strings). Otherwise space delimiters are
+assumed. if there is a mismatch in the filter vs param count,
+the command WILL fail.
+
+Filters may be any of:
+ Globbing filters
+ r %BReason%B
+ m %BMask%B (ident@host only)
+ s %BSetter%B
+ Regular Expression filters
+ R %BReason%B
+ M %BMask%B (ident@host only)
+ S %BSetter%B
+ Miscellaneous Filters
+ O/o %BOrder by%B (Sort by) - case insensitive.
+ negative is Descending, positive is Ascending.
+ You can specify multiple of these, but the
+ resulting sort order is not always intuitive.
+ Default is type,time,host Ascending.
+ Legal, but not necessarily meaningful for delete.
+ Available sort fields: %Btype%B, %Bident%B, %Bhost%B, %Bsetter%B,
+ %Bexpire%B, %Btime%B, %Breason%B.
+
+Example:
+
+TKL LIST -r+s *warez* *netadmin*
+would list all bans that do not include the word 'warez'
+and set by an oper with 'netadmin' in their vhost.
+
--- /dev/null
+%BSpamServ%B allows you to watch for unwanted spam.
+
+Commands:
+ WATCH Modify channels being watched
--- /dev/null
+%BSpamServ LISTCONF%B lists the known settings of
+the current configuration.
+
+Syntax: %LISTCONF%B
--- /dev/null
+%BSpamServ REHASH%B reloads the values of
+the configuration. This does not save any
+recently set values with the %BSET%B command.
+
+Syntax: %BREHASH%B
--- /dev/null
+%BSpamServ SAVE%B saves the list of watched channels
+as well as the current configuration.
+
+Syntax: %BSAVE%B
--- /dev/null
+%BSpamServ SET%B allows you to modify the
+configuration on the fly.
+
+Syntax: %BSET%B %Uoption%U <%Uvalue%U>
+
+Caveats: This command is limited toi previously
+known options in the configuration file. Use
+%BSpamServ LISTCONF%B to list those options.
--- /dev/null
+%BSpamServ WATCH%B modifies the list of channels being watched.
+
+ ADD - Add a channel to be watched for spam.
+ DEL - Remove a channel from being watched.
+ LIST - List channels currently being watched.
--- /dev/null
+%SpamServ WATCH ADD%B adds the specified channel
+to be watched by the SpamServ pseudoclients.
+
+Syntax: %BWATCH ADD%B %U#channel%U
--- /dev/null
+%BSpamServ WATCH DEL%B removes a channel from the watch
+list, causing the SpamServ pseudoclient to part the
+channel.
+
+Syntax: %BWATCH DEL%B %U#channel%U
--- /dev/null
+%BSpamServ WATCH LIST%B lists the currently watched
+channels.
+
+Syntax: %BWATCH LIST%B
--- /dev/null
+#!/bin/bash
+
+for X in `cat data/worker.pids`; do
+ kill $X
+done
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package event;
+use strict;
+
+use Event;
+use IO::Socket;
+
+# FIXME
+use SrSv::Timer;
+BEGIN { *addtimer = \&SrSv::Timer::add_timer }
+
+sub loop() {
+ Event::loop();
+}
+
+sub add_io_watcher(@) {
+ my $watcher = Event->io(@_);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package misc;
+use strict;
+
+sub isint($) {
+ my($x) = shift;
+ return (int($x) eq $x);
+}
+
+sub parse_quoted($) {
+ my ($in) = @_;
+ my @out;
+
+ my @qs = (
+ [qr/^\s*\"(.*?)(?<!\\)\"(.*)/,
+ sub { $_[0] =~ s/\\"/\"/g; return $_[0] }],
+ [qr/^\s*\/(.*?)(?<!\\)\/(.*)/,
+ sub { $_[0] =~ s#\\/#/#g; return $_[0] }],
+ [qr/(\S+)\s*(.*|$)/, undef]
+ );
+
+ do {
+ foreach my $q (@qs) {
+ my $str;
+ my ($re, $trans) = @$q;
+
+ if(my @x = ($in =~ $re)) {
+ ($str, $in) = @x;
+ $str = &$trans($str) if $trans;
+ push @out, $str;
+ #print "str: $str\nin: $in\n";
+ }
+ }
+ } while($in =~ /\S/);
+
+ return @out;
+}
+
+use constant { ORD_A => ord('A') };
+
+sub gen_uuid($$) {
+ my ($groups, $length) = @_;
+ my $emailreg_code = '';
+ for(my $i = 1; $i <= $groups; $i++) {
+ for (my $j = 1; $j <= $length; $j++) {
+ my $ch;
+ $emailreg_code .= (($ch = int(rand(36))) > 9 ? chr((ORD_A - 10) + $ch) : $ch);
+ }
+ $emailreg_code .= '-' unless $i >= $groups;
+ }
+ return $emailreg_code;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package modes;
+
+use strict;
+no strict 'refs';
+use constant {
+ DEBUG => 0,
+
+ DIFF => 1,
+ ADD => 2,
+ MERGE => 3
+};
+
+# This gives what we need to do to bring a current modeset into compliance
+# with a specified modeset (used for modelock)
+sub diff($$$) {
+ return calc($_[0], $_[1], $_[2], DIFF);
+}
+
+# This gives the result of applying the mode changes in the second parameter
+# to the existing modes in the first parameter.
+sub add($$$) {
+ return calc($_[0], $_[1], $_[2], ADD);
+}
+
+# This gives back the modes in the first parameter, with any modes in the
+# second overriding the first. (used to validate modelock setting)
+sub merge($$$) {
+ return calc($_[0], $_[1], $_[2], MERGE);
+}
+
+sub invert($) {
+ my @modes = split(/ /, $_[0]);
+
+ $modes[0] =~ tr/+-/-+/;
+
+ return join(' ', @modes);
+}
+
+# This removes the channel key, for info displays
+sub sanitize($) {
+ my ($modes, @parms) = split(/ /, $_[0]);
+ my @modes = split(//, $modes);
+ my ($c, $sign);
+
+ foreach my $m (@modes) {
+ if($m eq '+') { $sign = 1; next; }
+ if($m eq '-') { $sign = 0; next; }
+
+ if($sign) {
+ if($m =~ $ircd::ocm) {
+ $parms[$c] = '*' if $m eq 'k';
+ $c++;
+ }
+ }
+ }
+
+ return join(' ', $modes, @parms);
+}
+
+sub get_key($) {
+ my ($modes, @parms) = split(/ /, $_[0]);
+ my @modes = split(//, $modes);
+ my ($c, $sign);
+
+ foreach my $m (@modes) {
+ if($m eq '+') { $sign = 1; next; }
+ if($m eq '-') { $sign = 0; next; }
+
+ if($sign) {
+ if($m =~ $ircd::ocm) {
+ return $parms[$c] if ($m eq 'k');
+ $c++;
+ }
+ }
+ }
+
+ return undef;
+}
+
+# This is far from the best way to do it.
+#
+# 'bekfLlvhoaq' 'kfLlj'
+######
+# This really needs to be made more generic
+# learn more about $ircd::ocm $ircd::scm $ircd::acm
+######
+sub calc($$$$) {
+ my ($src, $dst, $chan, $type) = @_;
+
+ my ($smodes, @sargs) = split(/ /, $src);
+ my ($dmodes, @dargs) = split(/ /, $dst);
+
+ #$smodes =~ s/[bevhoaq]//g if $chan;
+
+ my @smodes = split(//, $smodes);
+ my @dmodes = split(//, $dmodes);
+
+ my $sign = 2;
+ my (@tmodes, @targs, @omodes, @oargs, $rmodes, @rargs, %status);
+
+ foreach my $x (@smodes) {
+ if($x eq '+') { $sign=2; next; }
+ if($x eq '-') { $sign=1; next; }
+ if($chan and $x =~ $ircd::scm) {
+ #shift @sargs if($sign == 2);
+ my $t = shift @sargs;
+ if($type == MERGE) {
+ my $key;
+ if($x =~ /^[beIk]$/) {
+ $key = $t;
+ } else {
+ $key = lc $t;
+ }
+ $status{$x}{$key} = $sign;
+ }
+ next;
+ }
+ if($chan and $x !~ $ircd::acm) {
+ next;
+ }
+
+ if($type == DIFF or $type == ADD) {
+ $tmodes[ord($x)] = $sign if $type == DIFF;
+ $omodes[ord($x)] = $sign if $type == ADD;
+
+ if($chan and $sign == 2 and $x =~ $ircd::ocm) {
+ $targs[ord($x)] = shift @sargs if $type == DIFF;
+ $oargs[ord($x)] = shift @sargs if $type == ADD;
+ }
+ }
+
+ elsif($type == MERGE) {
+ if($chan and $sign == 2 and $x =~ $ircd::ocm) {
+ if(
+ ($x eq 'l' and $sargs[0] =~ /^\d+$/) or
+ ($x eq 'L' and $sargs[0] =~ /^#/) or
+ $x eq 'f' or $x eq 'k' or
+ ($x eq 'j' and $sargs[0] =~ /^\d+\:\d+$/)
+ ) {
+ $omodes[ord($x)] = $sign;
+ $oargs[ord($x)] = shift @sargs;
+ }
+ } else {
+ $omodes[ord($x)] = $sign;
+ }
+ }
+ }
+
+ foreach my $x (@dmodes) {
+ if($x eq '+') { $sign=2; next; }
+ if($x eq '-') { $sign=1; next; }
+ if($chan and $x =~ $ircd::scm) {
+ #shift @dargs if($sign == 2);
+ my $t = shift @dargs;
+ if($type == MERGE) {
+ my $key;
+ if($x =~ /^[beIk]$/) {
+ $key = $t;
+ } else {
+ $key = lc $t;
+ }
+ $status{$x}{$key} = $sign;
+ }
+ next;
+ }
+ if($chan and $x !~ $ircd::acm) {
+ next;
+ }
+
+ if($chan and $sign == 2 and $x =~ $ircd::ocm) {
+ $oargs[ord($x)] = shift @dargs;
+ }
+
+ if(
+ $type == ADD or
+ $type == MERGE or
+ $type == DIFF and (
+ ($sign==2 or $tmodes[ord($x)]) and (
+ $sign != $tmodes[ord($x)] or
+ $targs[ord($x)] ne $oargs[ord($x)]
+ )
+ )
+ ) {
+ $omodes[ord($x)] = $sign;
+ }
+
+ # -k won't work without its parameter!
+ if($chan and $type == DIFF and $sign == 1 and $x eq 'k') {
+ $oargs[ord($x)] = $targs[ord($x)];
+ }
+ }
+
+ $sign = 0;
+ for(my $i = 0; $i < scalar @omodes; $i++) {
+ if($omodes[$i] == 2) {
+ if($sign != 2) { $sign = 2; $rmodes .= '+'; }
+ $rmodes .= chr($i);
+ push @rargs, $oargs[$i] if $oargs[$i];
+
+ }
+ }
+
+ if($type == MERGE) {
+ foreach my $m (keys(%status)) {
+ foreach my $v (keys(%{$status{$m}})) {
+ if($status{$m}{$v} == 2) {
+ if($sign != 2) { $sign = 2; $rmodes .= '+'; }
+ $rmodes .= $m;
+ push @rargs, $v;
+ }
+ }
+ }
+ }
+
+ if($type == DIFF or $type == MERGE) {
+ for(my $i = 0; $i < scalar @omodes; $i++) {
+ if($omodes[$i] == 1) {
+ if($sign != 1) { $sign = 1; $rmodes .= '-'; }
+ $rmodes .= chr($i);
+ push @rargs, $oargs[$i] if $oargs[$i];
+ }
+ }
+ }
+
+ if($type == MERGE) {
+ foreach my $m (keys(%status)) {
+ foreach my $v (keys(%{$status{$m}})) {
+ if($status{$m}{$v} == 1) {
+ if($sign != 1) { $sign = 1; $rmodes .= '-'; }
+ $rmodes .= $m;
+ push @rargs, $v;
+ }
+ }
+ }
+ }
+
+ #return undef if($rmodes eq '+');
+ print "modes::calc($src, $dst, $chan, $type)\n" if DEBUG();
+ print "--- MODE CALCULATED: ", join(' ', $rmodes, @rargs), "\n" if DEBUG();
+ return join(' ', $rmodes, @rargs);
+}
+
+# Splits modes into a hash
+# Skips modes in $ircd::scm (opmodes and banmodes)
+sub splitmodes($) {
+ my ($modes) = @_;
+ my (%modelist, @parms);
+ ($modes, @parms) = split(/ /, $modes);
+ my $sign = '+';
+ foreach my $mode (split(//, $modes)) {
+ if ($mode eq '+' or $mode eq '-') {
+ $sign = $mode;
+ }
+ elsif($mode =~ $ircd::scm) {
+ shift @parms;
+ }
+ elsif($mode =~ $ircd::ocm) {
+ push @{$modelist{$mode}}, $sign, shift @parms;
+ }
+ elsif($mode =~ $ircd::acm) {
+ push @{$modelist{$mode}}, $sign;
+ }
+ }
+ return %modelist;
+}
+
+sub splitumodes($) {
+ my ($modes) = @_;
+ my %modelist;
+ my $sign = '+';
+ foreach my $mode (split(//, $modes)) {
+ if ($mode eq '+' or $mode eq '-') {
+ $sign = $mode;
+ }
+ else {
+ $modelist{$mode} = $sign;
+ }
+ }
+ return %modelist;
+}
+
+# umodes that should not be settable by services
+# Most are OperModes [thus most are legal to be set for /os oper]
+our %unsafeumodes = (
+ o => 1, # Global Oper
+ O => 1, # Local Oper [wouldn't ever show up to remote servers]
+ A => 1, # Server Admin
+ C => 1, # Server CoAdmin (little diff in ability vs Admin)
+ a => 1, # Services Admin
+ N => 1, # Network Admin
+ W => 1, # See WHOIS events
+ g => 1, # see GLOBOPS
+ s => 1, # SNOMASKs. variable. has parameters, only settable via svssno
+ S => 1, # For Network Service Agents only. Protects from various
+ h => 1, # Can see /helpop msgs /.\ good for a helpop/helper
+ v => 1, # can see rejected/blocked DCC messages /.\ good for a helpop/helper
+ q => 1, # Can wok through walls. Kidding, avoid/block non-server/services kicks
+
+ z => 1, # Strictly speaking not unsafe, but shouldn't be allowed
+ t => 1, # Not unsafe either, but pointless as it won't have the desired effect
+ x => 1, # Ditto
+ r => 1 # This should be taken care of by identifying, if you're on a reg'd nick.
+);
+
+sub allowed_umodes($) {
+ my ($modes) = @_;
+ my %modelist = splitumodes($modes);
+ my ($rejected, $rejectedSign);
+ foreach my $mode (keys(%modelist)) {
+ if(defined ($unsafeumodes{$mode})) {
+ if(defined($rejectedSign) && $rejectedSign eq $modelist{$mode}) {
+ } else {
+ $rejectedSign = $modelist{$mode};
+ $rejected .= $rejectedSign;
+ }
+ $modelist{$mode} = undef;
+ $rejected .= $mode;
+ }
+ }
+ return (unsplit_umodes(%modelist), $rejected);
+}
+
+# split + unsplit equals a modes::merge for umodes
+sub unsplit_umodes(%) {
+ my (%modelist) = @_;
+ my ($upmodes, $downmodes) = ('', '');
+ foreach my $mode (keys(%modelist)) {
+ if ($modelist{$mode} eq '+') {
+ $upmodes .= $mode;
+ }
+ elsif ($modelist{$mode} eq '-') {
+ $downmodes .= $mode;
+ }
+ }
+ return ($upmodes ne '' ? "+$upmodes" : '').($downmodes ne '' ? "-$downmodes" : '');
+}
+
+sub merge_umodes($;$) {
+# second param is optional as we may want to merge a string of mixed modes '+rh-x+i'
+ my ($umodes1, $umodes2) = @_;
+ return modes::unsplit_umodes(modes::splitumodes($umodes1 . ($umodes2 ? $umodes2 : '' ) ) );
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package module;
+use strict;
+no strict 'refs';
+
+use Symbol qw(delete_package);
+
+use SrSv::Conf2Consts qw(main);
+
+use constant {
+ ST_UNLOADED => 0,
+ ST_LOADED => 1,
+ ST_READY => 2,
+};
+
+our %modules;
+our %packages;
+our @modules;
+
+our @unload;
+our @load;
+
+sub load(@) {
+ my @m = @_;
+ @m = @modules = split(/\s*,\s*/, main_conf_load) unless @m;
+
+ foreach my $module (@m) {
+ next if ($modules{$module} and $modules{$module}[0] and !($modules{$module}[0] == ST_UNLOADED));
+
+ my $m = "./modules/$module.pm";
+ print "Loading module $module..."; # if $main::status==main::ST_PRECONNECT();
+ eval { require $m };
+ if($@) {
+ #if($main::status==main::ST_PRECONNECT()) {
+ print qq{ FAILED.\n\nModule "$module" failed to load.\n};
+
+ my $error = $@;
+ $error =~ s/\n(?:BEGIN failed--|Compilation failed in require).*(?:\n|$)//sg unless main::DEBUG();
+ print "Please read INSTALL and README.\nOr if you just upgraded, see UPGRADING.\n" unless main::DEBUG();
+ print "\n$error\n";
+ exit;
+ #} else {
+ # return $@;
+ #}
+ }
+
+ foreach my $p (@{"$module\::packages"}) {
+ $packages{$p}{$module} = 1;
+ }
+
+ print " done.\n"; #if $main::status==main::ST_PRECONNECT();
+
+ $modules{$module}[0] = ST_LOADED;
+ }
+
+ foreach my $module (@m) {
+ my $m = "$module\::init";
+ eval { &$m(); };
+
+ if($@) {
+ print qq{ FAILED.\n\nModule "$module" failed to load.\n};
+ print "\n$@\n";
+ exit;
+ }
+ }
+
+ return undef;
+}
+
+sub unload(@) {
+ my @m = @_;
+ @m = @modules unless @m;
+
+ unload_lazy(@m);
+
+ foreach my $module (@m) {
+ next unless $modules{$module}[0] == ST_UNLOADED;
+
+ delete_package $module;
+
+ foreach my $p (keys(%packages)) {
+ delete $packages{$p}{$module};
+
+ unless(keys(%{$packages{$p}})) {
+ delete_package $p;
+ }
+ }
+ }
+}
+
+sub unload_lazy(@) {
+ my @m = @_;
+ @m = @modules unless @m;
+
+ foreach my $module (@m) {
+ next unless $modules{$module}[0] == ST_LOADED;
+
+ my $m = "$module\::unload";
+ eval { &$m };
+ print $@ if $@;
+
+ $modules{$module}[0] = ST_UNLOADED;
+ }
+}
+
+sub begin(@) {
+ my @m = @_;
+ @m = @modules unless @m;
+
+ foreach my $module (@m) {
+ next unless $modules{$module}[0] == ST_LOADED;
+
+ my $m = "$module\::begin";
+ eval { &$m };
+ print $@ if $@;
+
+ $modules{$module}[0] = ST_READY;
+ }
+}
+
+sub end(@) {
+ my @m = @_;
+ @m = @modules unless @m;
+
+ foreach my $module (@m) {
+ next unless $modules{$module}[0] == ST_READY;
+
+ my $m = "$module\::end";
+ eval { &$m };
+ print $@ if $@;
+
+ $modules{$module}[0] = ST_LOADED;
+ }
+}
+
+sub is_loaded(@) {
+ foreach my $module (@_) {
+ return 0 if($modules{$module}[0] == ST_UNLOADED);
+ }
+
+ return 1;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package connectserv;
+
+use strict;
+no strict 'refs';
+
+use SrSv::IRCd::State qw( initial_synced synced );
+use SrSv::IRCd::Event 'addhandler';
+use SrSv::RunLevel qw( $runlevel :levels );
+
+use SrSv::Conf::Parameters connectserv => [
+ [ joinpart => 0 ],
+];
+
+use SrSv::Conf2Consts qw( main connectserv );
+
+use SrSv::Log;
+
+use SrSv::Process::InParent qw(
+ ev_nickconn ev_nickchange ev_quit ev_kill ev_umode ev_connect message
+);
+
+my %userlist;
+
+use SrSv::Agent;
+
+my $csnick = 'ConnectServ';
+
+agent_connect($csnick, 'services', undef, '+pqzBHS', 'Connection Monitor');
+agent_join($csnick, main_conf_diag);
+ircd::setmode($csnick, main_conf_diag, '+o', $csnick);
+
+addhandler('NICKCONN', undef, undef, 'connectserv::ev_nickconn', 1);
+sub ev_nickconn {
+ my ($nick, $ident, $host, $server, $gecos) = @_[0,3,4,5,9];
+
+ $userlist{lc $nick} = [$ident, $host, $gecos, $server];
+
+ return unless initial_synced();
+ message("\00304\002SIGNED ON\002 user: \002$nick\002 ($ident\@$host - $gecos\017\00304) at $server");
+}
+
+addhandler('NICKCHANGE', undef, undef, 'connectserv::ev_nickchange', 1);
+sub ev_nickchange {
+ my ($old, $new) = @_;
+ my ($ident, $host);
+ unless(lc($new) eq lc($old)) {
+ $userlist{lc $new} = $userlist{lc $old};
+ delete($userlist{lc $old});
+ }
+ ($ident, $host) = @{$userlist{lc $new}} if (defined($userlist{lc $new}));
+ message("\00307\002NICK CHANGE\002 user: \002$old\002 ($ident\@$host) changed their nick to \002$new\002");
+}
+
+addhandler('CHGIDENT', undef, undef, 'connectserv::ev_identchange', 1);
+sub ev_identchange {
+ my (undef, $nick, $ident) = @_;
+
+ my ($oldident, $host, $gecos, $server);
+ ($oldident, $host, $gecos, $server) = @{$userlist{lc $nick}} if (defined($userlist{lc $nick}));
+ $userlist{lc $nick} = [$ident, $host, $gecos, $server];
+
+ message("\00310\002IDENT CHANGE\002 user: \002$nick\002 ($oldident\@$host) changed their virtual ident to \002$ident\002");
+}
+
+addhandler('QUIT', undef, undef, 'connectserv::ev_quit', 1);
+sub ev_quit {
+ my ($nick, $reason) = @_;
+ return unless synced() && $runlevel == ST_NORMAL;
+ my ($ident, $host, $gecos, $server);
+ if(defined($userlist{lc $nick})) {
+ ($ident, $host, $gecos, $server) = @{$userlist{lc $nick}};
+ delete($userlist{lc $nick});
+ }
+ return unless initial_synced();
+ message("\00303\002SIGNED OFF\002 user: \002$nick\002 ($ident\@$host - $gecos\017\00303) at $server - $reason");
+}
+
+addhandler('KILL', undef, undef, 'connectserv::ev_kill', 1);
+sub ev_kill {
+ my ($src, $target, $reason) = @_[0,1,3];
+ my ($ident, $host, $gecos, $server);
+ if(defined($userlist{lc $target})) {
+ ($ident, $host, $gecos, $server) = @{$userlist{lc $target}};
+ delete($userlist{lc $target});
+ }
+ message("\00302\002GLOBAL KILL\002 user: \002$target\002 ($ident\@$host) killed by \002$src\002 - $reason");
+}
+
+addhandler('UMODE', undef, undef, 'connectserv::ev_umode', 1);
+sub ev_umode {
+ my ($nick, $modes) = @_;
+ my @modes = split(//, $modes);
+ my $sign;
+ foreach my $m (@modes) {
+ $sign = 1 if $m eq '+';
+ $sign = 0 if $m eq '-';
+
+ my $label;
+ $label = 'Global Operator' if $m eq 'o';
+ $label = 'Services Administrator' if $m eq 'a';
+ $label = 'Server Administrator' if $m eq 'A';
+ $label = 'Network Administrator' if $m eq 'N';
+ $label = 'Co Administrator' if $m eq 'C';
+ $label = 'Bot' if $m eq 'B';
+
+ if($label) {
+ message("\00306\002$nick\002 is ".($sign ? 'now' : 'no longer')." a \002$label\002 (".($sign ? '+' : '-')."$m)");
+ }
+ }
+}
+
+addhandler('SJOIN', undef, undef, 'connectserv::chan_join', 1) if connectserv_conf_joinpart;
+sub chan_join {
+ my ($server, $cn, $ts, $chmodes, $chmodeparms, $userarray, $banarray, $exceptarray) = @_;
+ return unless synced() && $runlevel == ST_NORMAL;
+ foreach my $user (@$userarray) {
+ my $nick = $user->{NICK};
+ message ("\00310CHANNEL JOIN: \002$nick\002 joined to \002$cn\002\003");
+ }
+}
+
+addhandler('PART', undef, undef, 'connectserv::chan_part', 1) if connectserv_conf_joinpart;
+sub chan_part {
+ my ($nick, $cn) = @_;
+ return unless synced() && $runlevel == ST_NORMAL;
+ message ("\00310CHANNEL PART: \002$nick\002 parted from \002$cn\002\003");
+}
+
+addhandler('JOIN', undef, undef, 'connectserv::chan_join0', 1) if connectserv_conf_joinpart;
+sub chan_join0 {
+ my ($nick, $cn) = @_;
+ return unless synced() && $runlevel == ST_NORMAL;
+ if($cn eq '0') {
+ message ("\00310CHANNEL PART: \002$nick\002 parted all channels\003");
+ } else {
+ message ("\00310CHANNEL JOIN: \002$nick\002 joined to \002$cn\002\003");
+ }
+}
+
+sub message(@) {
+ ircd::privmsg($csnick, main_conf_diag, @_);
+ write_log('diag', '<'.$csnick.'>', @_);
+}
+
+sub init { }
+sub begin { }
+sub end { }
+sub unload { }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package core;
+use strict;
+
+#use SrSv::Conf 'main';
+use SrSv::Conf2Consts 'main';
+use SrSv::RunLevel 'main_shutdown';
+use SrSv::IRCd::Event 'addhandler';
+use SrSv::IRCd::IO 'ircsend';
+use SrSv::Timer 'add_timer';
+use SrSv::Time 'time_rel_long_all';
+use SrSv::Agent;
+use SrSv::Process::Init; #FIXME - only needed for ccode
+use SrSv::User::Notice;
+use SrSv::Help;
+
+my $startTime = time();
+
+our %ccode; #FIXME - Split out
+proc_init {
+ open ((my $COUNTRY), main::PREFIX()."/data/country-codes.txt");
+ while(my $x = <$COUNTRY>) {
+ chomp $x;
+ my($code, $country) = split(/ /, $x);
+ $ccode{uc $code} = $country;
+ }
+ close $COUNTRY;
+};
+
+our $rsnick = 'ServServ';
+
+addhandler('STATS', undef, undef, 'core::stats');
+sub stats($$) {
+ my ($src, $token) = @_;
+ if($token eq 'u') {
+ ircsend('242 '.$src.' :Server up '.time_rel_long_all($startTime),
+ '219 '.$src.' u :End of /STATS report')
+ }
+}
+
+addhandler('PING', undef, undef, 'ircd::pong', 1);
+
+sub pingtimer($) {
+ ircd::ping();
+ add_timer('perlserv__pingtimer', 60, __PACKAGE__,
+ "core::pingtimer");
+}
+
+agent_connect($rsnick, 'service', undef, '+ABHSNaopqz', 'Services Control Agent');
+agent_join($rsnick, main_conf_diag);
+ircd::setmode($rsnick, main_conf_diag, '+o', $rsnick);
+
+addhandler('SEOS', undef, undef, 'core::ev_connect', 1);
+
+sub ev_connect {
+ add_timer('perlserv__pingtimer', 60, __PACKAGE__,
+ "core::pingtimer");
+}
+
+addhandler('PRIVMSG', undef, 'servserv', 'core::dispatch', 1);
+
+sub dispatch {
+ my ($src, $dst, $msg) = @_;
+ my $user = { NICK => $src, AGENT => $rsnick };
+ if(!adminserv::is_ircop($user)) {
+ notice($user, 'Access Denied');
+ ircd::globops($rsnick, "\002$src\002 failed access to $rsnick $msg");
+ return;
+ }
+ if($msg =~ /^lsmod/i) {
+ notice($user, main_conf_load);
+ }
+
+ if($msg =~ /^shutdown/i) {
+ if(!adminserv::is_svsop($user, adminserv::S_ADMIN() )) {
+ notice($user, 'You do not have sufficient rank for this command');
+ return;
+ }
+
+ main_shutdown;
+ }
+ if($msg =~ /^raw/i) {
+ if(!adminserv::is_svsop($user, adminserv::S_ROOT() )) {
+ notice($user, 'You do not have sufficient rank for this command');
+ return;
+ }
+ my $cmd = $msg;
+ $cmd =~ s/raw\s+//i;
+ ircsend($cmd);
+ }
+ if($msg =~ /^help$/) {
+ sendhelp($user, lc 'core');
+ return;
+ }
+ if(main::DEBUG and $msg =~ /^eval\s+(.*)/) {
+ my $out = eval($1);
+ notice($user, split(/\n/, $out.$@));
+ }
+}
+
+sub init { }
+sub begin { }
+sub end { }
+sub unload { }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+#
+# Copyright tabris@surrealchat.net (C) 2005
+package country;
+
+use strict;
+
+use SrSv::MySQL '$dbh';
+use SrSv::Process::Init;
+use SrSv::IRCd::Event 'addhandler';
+use SrSv::IRCd::State 'initial_synced';
+
+use SrSv::Log;
+
+use SrSv::Shared qw(%unwhois);
+
+use SrSv::User qw(get_user_id);
+
+addhandler('USERIP', undef, undef, 'userip');
+addhandler('NICKCONN', undef, undef, 'nickconn');
+
+our ($get_ip_country, $get_ip_country_aton, $get_user_country);
+
+proc_init {
+ $get_ip_country = $dbh->prepare_cached("SELECT country FROM country WHERE
+ ? BETWEEN low AND high");
+ $get_ip_country_aton = $dbh->prepare_cached("SELECT country FROM country WHERE
+ INET_ATON(?) BETWEEN low AND high");
+ $get_user_country = $dbh->prepare_cached("SELECT country FROM country, user WHERE
+ user.ip BETWEEN low AND high and user.id=?");
+};
+
+sub get_ip_country($) {
+ my ($ip) = @_;
+
+ $get_ip_country->execute($ip);
+ my ($country) = $get_ip_country->fetchrow_array();
+ $get_ip_country->finish();
+
+ return $country;
+}
+
+sub get_ip_country_aton($) {
+# IP is expected to be a dotted quad string!
+ my ($ip) = @_;
+
+ $get_ip_country_aton->execute($ip);
+ my ($country) = $get_ip_country_aton->fetchrow_array();
+ $get_ip_country_aton->finish();
+ #my ($country)= $dbh->selectrow_array(
+ # "SELECT `country` FROM `country` WHERE `low` < INET_ATON('$ip') AND `high` > INET_ATON('$ip')");
+ #$dbh->finish();
+
+ return $country;
+}
+
+sub get_user_country($) {
+# Preferred to use this if you have a $user hash and you've set the IP.
+# it should return undef in the case of user.ip == 0
+# do check this case in the caller before assuming the return value is valid.
+ my ($user) = @_;
+
+ $get_user_country->execute(get_user_id($user));
+ my ($country) = $get_user_country->fetchrow_array();
+ $get_user_country->finish();
+
+ return $country;
+}
+
+sub get_country_long($) {
+# I'd prefer that this be used by the callers of get_user_country()
+# If they need the long country name,
+# they can use country::get_country_long(country::get_user_country($user))
+# that way the get_{user,ip}_country functions get back an easily parsed value.
+ my ($country) = @_;
+ $country = uc $country;
+
+ my $cname = $core::ccode{$country};
+ $country .= " ($cname)" if $cname;
+
+ return $country if $cname;
+ return 'Unknown';
+}
+
+sub get_user_country_long($) {
+ my ($user) = @_;
+ return get_country_long(get_user_country($user));
+}
+
+sub nickconn {
+ my ($rnick, $time, $ident, $host, $vhost, $server, $modes, $gecos, $ip, $svsstamp) = @_[0,2..4,8,5,7,9,10,6];
+ if(initial_synced() && !$svsstamp) {
+ if ($ip) {
+ wlog($main::rsnick, LOG_INFO(), "\002$rnick\002 is connecting from ".
+ get_country_long(get_ip_country_aton($ip)));
+ }
+ else {
+ $unwhois{lc $rnick} = 1;
+ }
+ }
+ # we already depend on services being up for our SQL,
+ # thus we know a USERIP will be sent.
+ # However this IS avoidable if we make our own SQL connection
+ # but would then require an additional %config and configfile
+ return;
+}
+
+sub userip($$$) {
+ my($src, $nick, $ip) = @_;
+
+ return unless($unwhois{lc $nick});
+ return unless($ip =~ /^\d{1,3}(\.\d{1,3}){3}$/);
+
+ wlog($main::rsnick, LOG_INFO(), "\002$nick\002 is connecting from ".
+ get_country_long(get_ip_country_aton($ip)));
+ delete $unwhois{lc $nick};
+}
+
+sub init() { }
+sub begin() { }
+sub end() { %unwhois = undef(); }
+sub unload() { }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package echoserv;
+use strict;
+
+use SrSv::IRCd::Event qw( addhandler );
+use SrSv::Agent;
+use SrSv::Conf2Consts qw( main );
+
+my $esnick = 'EchoServ';
+
+addhandler('PRIVMSG', undef, lc $esnick, 'echoserv::ev_privmsg');
+sub ev_privmsg { ircd::privmsg($_[1], $_[0], $_[2]) }
+
+addhandler('NOTICE', undef, lc $esnick, 'echoserv::ev_notice');
+sub ev_notice { ircd::notice($_[1], $_[0], $_[2]) }
+
+agent_connect($esnick, 'services', undef, '+pqzBGHS', 'Echo Server');
+agent_join($esnick, main_conf_diag);
+ircd::setmode($esnick, main_conf_diag, '+o', $esnick);
+
+sub init { }
+sub begin { }
+sub end { }
+sub unload { }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+#
+# Copyright tabris@surrealchat.net (C) 2005, 2008
+package geoip;
+
+use strict;
+
+use SrSv::MySQL '$dbh';
+use SrSv::Process::Init;
+use SrSv::IRCd::Event 'addhandler';
+use SrSv::IRCd::State 'initial_synced';
+
+use SrSv::Log;
+
+use SrSv::Shared qw(%unwhois);
+
+use SrSv::User qw(get_user_id);
+
+addhandler('USERIP', undef, undef, 'userip');
+addhandler('NICKCONN', undef, undef, 'nickconn');
+
+our ($get_ip_location, $get_ip_location_aton, $get_user_location);
+
+proc_init {
+ my $baseSQL = "SELECT geolocation.country, geolocation.region,
+ geocountry.country, georegion.name, geolocation.city, geolocation.postalcode,metrocode.metro
+ FROM geolocation
+ JOIN geoip ON (geolocation.id=geoip.location)
+ LEFT JOIN geocountry ON (geolocation.country=geocountry.code)
+ LEFT JOIN georegion ON (geolocation.country=georegion.country AND geolocation.region=georegion.region)
+ LEFT JOIN metrocode ON (metrocode.id=geolocation.metrocode) ";
+ #"WHERE MBRCONTAINS(ip_poly, POINTFROMWKB(POINT(INET_ATON( ? ), 0)))";
+ $get_ip_location = $dbh->prepare_cached("$baseSQL
+ WHERE MBRCONTAINS(ip_poly, POINTFROMWKB(POINT( ?, 0)))");
+ $get_ip_location_aton = $dbh->prepare_cached("$baseSQL
+ WHERE MBRCONTAINS(ip_poly, POINTFROMWKB(POINT(INET_ATON( ? ), 0)))");
+ $get_user_location = $dbh->prepare_cached("$baseSQL
+ JOIN user
+ WHERE MBRCONTAINS(ip_poly, POINTFROMWKB(POINT(user.ip, 0)))
+ AND user.id=?");
+};
+
+sub get_ip_location($) {
+ my ($ip) = @_;
+
+ $get_ip_location->execute($ip);
+ my ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro) =
+ $get_ip_location->fetchrow_array();
+ $get_ip_location->finish();
+ if(!defined($countryCode)) {
+ $countryCode = '-';
+ $countryName = 'Unknown';
+ }
+
+ if(wantarray) {
+ return ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro);
+ } else {
+ return $countryCode;
+ }
+}
+
+sub get_ip_location_aton($) {
+# IP is expected to be a dotted quad string!
+ my ($ip) = @_;
+
+ $get_ip_location_aton->execute($ip);
+ my ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro) =
+ $get_ip_location_aton->fetchrow_array();
+ $get_ip_location_aton->finish();
+ #my ($country)= $dbh->selectrow_array(
+ # "SELECT `country` FROM `country` WHERE `low` < INET_ATON('$ip') AND `high` > INET_ATON('$ip')");
+ #$dbh->finish();
+ if(!defined($countryCode)) {
+ $countryCode = '-';
+ $countryName = 'Unknown';
+ }
+
+ if(wantarray) {
+ return ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro);
+ } else {
+ return $countryCode;
+ }
+}
+
+sub get_user_location($) {
+# Preferred to use this if you have a $user hash and you've set the IP.
+# it should return undef in the case of user.ip == 0
+# do check this case in the caller before assuming the return value is valid.
+ my ($user) = @_;
+
+ $get_user_location->execute(get_user_id($user));
+ my ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro) =
+ $get_user_location->fetchrow_array();
+ $get_user_location->finish();
+ if(!defined($countryCode)) {
+ $countryCode = '-';
+ $countryName = 'Unknown';
+ }
+
+ if(wantarray) {
+ return ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro);
+ } else {
+ return $countryCode;
+ }
+}
+
+sub stringify_location(@) {
+ my ($countryCode, $regionCode, $countryName, $regionName, $city, $postalCode, $metro) = @_;
+ my $location;
+ if(!defined($countryCode) || $countryCode eq '-') {
+ $location = "Unknown";
+ } else {
+ $location = "$countryName";
+ if(defined($city) && length($city)) {
+ $location .= " ($city";
+ }
+ if(defined($regionName)) {
+ if($regionName =~ /, /) {
+ #normalize stuff like "London, City of"
+ $regionName = join(' ', reverse(split(', ', $regionName)));
+ }
+ $location .= (defined($city) && length($city)) ? ', ' : '(';
+ $location .= "$regionName)";
+ } elsif(defined($city) && length($city)) {
+ $location .= ')';
+ }
+ if(defined($metro)) {
+ $location .= " [$metro]";
+ }
+ }
+ return $location;
+}
+
+sub nickconn {
+ my ($rnick, $time, $ident, $host, $vhost, $server, $modes, $gecos, $ip, $svsstamp) = @_[0,2..4,8,5,7,9,10,6];
+ if(initial_synced() && !$svsstamp) {
+ if ($ip) {
+ wlog($main::rsnick, LOG_INFO(), "\002$rnick\002 is connecting from ".
+ stringify_location(get_ip_location_aton($ip)));
+ }
+ else {
+ $unwhois{lc $rnick} = 1;
+ }
+ }
+ # we already depend on services being up for our SQL,
+ # thus we know a USERIP will be sent.
+ # However this IS avoidable if we make our own SQL connection
+ # but would then require an additional %config and configfile
+ return;
+}
+
+sub userip($$$) {
+ my($src, $nick, $ip) = @_;
+
+ return unless($unwhois{lc $nick});
+ return unless($ip =~ /^\d{1,3}(\.\d{1,3}){3}$/);
+
+
+ ;
+ wlog($main::rsnick, LOG_INFO(), "\002$nick\002 is connecting from ".
+ stringify_location(get_ip_location_aton($ip)));
+ delete $unwhois{lc $nick};
+}
+
+sub init() { }
+sub begin() { }
+sub end() { %unwhois = undef(); }
+sub unload() { }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package logserv;
+
+use strict;
+no strict 'refs';
+use Storable;
+
+use SrSv::Process::InParent qw(chanlog addchan delchan ev_sjoin ev_join ev_part
+ev_kick ev_mode ev_nickconn ev_nickchange ev_quit ev_message ev_notice
+ev_chghost ev_kill ev_topic ev_connect saveconf loadconf join_chans);
+
+use SrSv::Conf2Consts qw(main);
+use SrSv::IRCd::Event 'addhandler';
+use SrSv::IRCd::State 'initial_synced';
+use SrSv::Agent;
+use SrSv::User::Notice;
+use SrSv::Log qw( :all );
+
+my %userlist;
+my %chanlist;
+
+our $lsnick = 'LogServ';
+my $chanopmode = '+v';
+
+loadconf();
+agent_connect($lsnick, 'services', undef, '+pqzBHSD', 'Log Service');
+agent_join($lsnick, main_conf_diag);
+ircd::setmode($lsnick, main_conf_diag, '+o', $lsnick);
+join_chans();
+
+sub chanlog($@) {
+ my ($cn, @payload) = @_;
+ write_log("logserv:$cn", '', @payload)
+ # This if allows us to be lazy
+ if defined($chanlist{lc $cn});
+}
+
+sub addchan($$) {
+ my ($user, $cn) = @_;
+ unless(defined($chanlist{lc $cn})) {
+ open_log("logserv:$cn", lc($cn).'.log');
+ $chanlist{lc $cn} = 1;
+ agent_join($lsnick, $cn);
+ ircd::setmode($lsnick, $cn, $chanopmode, $lsnick);
+ notice($user, "Channel $cn will now be logged");
+ saveconf();
+ return 1;
+ } else {
+ notice($user, "Channel $cn is already being logged");
+ return 0;
+ }
+}
+
+sub delchan($$) {
+ my ($user, $cn) = @_;
+ if(defined($chanlist{lc $cn})) {
+ close_log("logserv:$cn");
+ delete($chanlist{lc $cn});
+ agent_part($lsnick, $cn, "Channel has been deleted by ".$user->{NICK});
+ notice($user, "Channel $cn will not be logged");
+ saveconf();
+ return 1;
+ } else {
+ notice($user, "Channel $cn is not being logged");
+ return 0;
+ }
+}
+
+# Handler Functions
+
+addhandler('SJOIN', undef, undef, 'logserv::ev_sjoin');
+sub ev_sjoin {
+ # ($server, $cn, $ts, $chmodes, $chmodeparms, \@users, \@bans, \@excepts, \@invex);
+ my (undef, $cn, undef, undef, undef, $users, undef, undef, undef) = @_;
+ foreach my $user (@$users) {
+ ev_join($user->{NICK}, $cn);
+ }
+}
+
+addhandler('JOIN', undef, undef, 'logserv::ev_join');
+sub ev_join {
+ my ($nick, $cn) = @_;
+ return if is_agent($nick); # Ignore agent joins.
+ return unless defined($userlist{lc $nick}); # Sometimes we get JOINs after a KILL or QUIT
+ {
+ $userlist{lc $nick}{CHANS}{$cn} = 1;
+ }
+ if(initial_synced()) {
+ if($cn eq '0') {
+ foreach my $cn (keys(%{$userlist{lc $nick}{CHANS}})) {
+ ev_part($nick, $cn, 'Left all channels');
+ }
+ } else {
+ my ($ident, $vhost) = @{$userlist{lc $nick}{INFO}};
+ chanlog($cn, "-!- $nick [$ident\@$vhost] has joined $cn");
+ }
+ }
+}
+
+addhandler('PART', undef, undef, 'logserv::ev_part');
+sub ev_part {
+ my ($nick, $cn, $reason) = @_;
+ return if is_agent($nick); # Ignore agent parts.
+ return unless defined($userlist{lc $nick}); # Sometimes we get JOINs after a KILL or QUIT
+ {
+ delete($userlist{lc $nick}{CHANS}{$cn});
+ }
+ my ($ident, $vhost) = @{$userlist{lc $nick}{INFO}};
+ chanlog("$cn", "-!- $nick [$ident\@$vhost] has left $cn [$reason]");
+}
+
+addhandler('KICK', undef, undef, 'logserv::ev_kick');
+sub ev_kick {
+ my ($src, $cn, $target, $reason) = @_;
+ return unless defined($userlist{lc $target}); # Sometimes we get JOINs after a KILL or QUIT
+ if(lc $target eq lc $lsnick) {
+ agent_join($lsnick, $cn);
+ ircd::setmode($lsnick, $cn, '+o', $lsnick);
+ return;
+ }
+ {
+ delete($userlist{lc $target}{CHANS}{$cn});
+ }
+ chanlog("$cn", "-!- $target was kicked by $src [$reason]");
+}
+
+addhandler('MODE', undef, undef, 'logserv::ev_mode');
+sub ev_mode {
+ my ($src, $cn, $modes, $parms) = @_;
+ return unless initial_synced();
+ chanlog("$cn", "-!- mode/$cn [$modes".($parms ? " $parms" : '')."] by $src");
+}
+
+addhandler('NICKCONN', undef, undef, 'logserv::ev_nickconn');
+sub ev_nickconn {
+ my ($nick, $ident, $host, $modes, $vhost, $cloakhost) = @_[0,3,4,7,8,11];
+ if ($vhost eq '*') {
+ if ({modes::splitumodes($modes)}->{x} eq '+') {
+ if(defined($cloakhost)) {
+ $vhost = $cloakhost;
+ }
+ else {
+ # Since we have no desire to do ircd::userhost checks
+ # This makes us dependent on VHP or CLK.
+ # Do we care? Not at the moment.
+ # This should NEVER happen with VHP or CLK.
+ $vhost = $host;
+ }
+ } else {
+ $vhost = $host;
+ }
+ }
+ $userlist{lc $nick} = {
+ INFO => [$ident, $vhost],
+ CHANS => {},
+ };
+}
+
+addhandler('NICKCHANGE', undef, undef, 'logserv::ev_nickchange');
+sub ev_nickchange {
+ my ($old, $new) = @_;
+ return unless defined($userlist{lc $old}); # Sometimes we get JOINs after a KILL or QUIT
+ unless (lc($old) eq lc($new)) {
+ $userlist{lc $new} = $userlist{lc $old};
+ delete($userlist{lc $old});
+ }
+ foreach my $cn (keys(%{$userlist{lc $new}{CHANS}})) {
+ chanlog($cn, "-!- $old is now known as $new");
+ }
+}
+
+addhandler('QUIT', undef, undef, 'logserv::ev_quit');
+sub ev_quit {
+ my ($nick, $reason) = @_;
+ my ($ident, $vhost) = @{$userlist{lc $nick}{INFO}};
+ if (initial_synced()) {
+ foreach my $cn (keys(%{$userlist{lc $nick}{CHANS}})) {
+ chanlog($cn, "$nick [$ident\@$vhost] has quit [$reason]");
+ }
+ }
+ delete($userlist{lc $nick});
+}
+
+addhandler('LOOP_PRIVMSG', undef, qr/^#/, 'logserv::ev_loop_message');
+sub ev_loop_message {
+ my ($nick, $cn, $messages) = @_;
+ my $channel = $cn;
+ $channel =~ s/^[+%@&~]+//;
+ return unless defined($chanlist{lc $channel});
+ foreach my $message (@$messages) {
+ if ($message =~ /^\001(\w+)(?: (.*))\001$/i) {
+ my ($ctcp, $payload) = ($1, $2);
+ if($ctcp eq 'ACTION') {
+ $message = "* $nick $payload";
+ }
+ else {
+ $message = "$nick requested CTCP $1 from $cn: $2";
+ }
+ } else {
+ $message = "<$nick> $message";
+ }
+ }
+ chanlog($channel, @$messages);
+}
+addhandler('LOOP_NOTICE', undef, qr/^#/, 'logserv::ev_loop_notice');
+sub ev_loop_notice {
+ my ($nick, $cn, $messages) = @_;
+ my $channel = $cn;
+ $channel =~ s/^[+%@&~]+//;
+ return unless defined($chanlist{lc $channel});
+ foreach my $message (@$messages) {
+ $message = "-$nick:$cn- $message";
+ }
+ chanlog($channel, @$messages);
+}
+
+addhandler('PRIVMSG', undef, qr/^#/, 'logserv::ev_message');
+sub ev_message {
+ my ($nick, $cn, $message) = @_;
+ my $channel = $cn;
+ $channel =~ s/^[+%@&~]+//;
+ return unless defined($chanlist{lc $channel});
+ if ($message =~ /^\001(\w+)(?: (.*))\001$/i) {
+ my ($ctcp, $payload) = ($1, $2);
+ if($ctcp eq 'ACTION') {
+ chanlog($channel, "* $nick $payload");
+ }
+ else {
+ chanlog($channel, "$nick requested CTCP $1 from $cn: $2");
+ }
+ } else {
+ chanlog($channel, "<$nick> $message");
+ }
+
+}
+addhandler('NOTICE', undef, qr/^#/, 'logserv::ev_notice');
+sub ev_notice {
+ my ($nick, $cn, $message) = @_;
+ my $channel = $cn;
+ $channel =~ s/^[+%@&~]+//;
+ return unless defined($chanlist{lc $channel});
+ chanlog($channel, "-$nick:$cn- $message");
+}
+
+addhandler('CHGHOST', undef, undef, 'logserv::ev_chghost');
+sub ev_chghost {
+ my (undef, $nick, $vhost) = @_;
+ return unless defined($userlist{lc $nick}); # Sometimes we get JOINs after a KILL or QUIT
+ {
+ my ($ident, undef) = @{$userlist{lc $nick}{INFO}};
+ $userlist{lc $nick}{INFO} = [$ident, $vhost];
+ }
+
+}
+
+addhandler('KILL', undef, undef, 'logserv::ev_kill');
+sub ev_kill {
+ my ($src, $target, $reason) = @_;
+ return if is_agent($target) or !defined($userlist{lc $target}); # Ignore agent kills.
+ my ($ident, $vhost) = @{$userlist{lc $target}{INFO}};
+ if (initial_synced()) {
+ foreach my $cn (keys(%{$userlist{lc $target}{CHANS}})) {
+ chanlog($cn, "$target [$ident\@$vhost] has quit [Killed ($src ($reason))]");
+ }
+ }
+ delete($userlist{lc $target});
+}
+
+addhandler('TOPIC', undef, undef, 'logserv::ev_topic');
+sub ev_topic {
+ my ($src, $cn, $setter, undef, $topic) = @_;
+ # We don't care about the timestamp
+ return unless initial_synced();
+ chanlog($cn, "$src changed the topic of $cn to: $topic".($setter ne $src ? " ($setter)" : ''));
+}
+
+# Internal Only functions.
+
+sub saveconf() {
+ my @channels = keys(%chanlist);
+ Storable::nstore(\@channels, "config/logserv/chans.conf");
+}
+
+sub loadconf() {
+ (-d "config/logserv") or mkdir "config/logserv";
+ return unless(-f "config/logserv/chans.conf");
+ my @channels = @{Storable::retrieve("config/logserv/chans.conf")};
+ foreach my $cn (@channels) {
+ $chanlist{lc $cn} = 1;
+ }
+}
+
+sub join_chans() {
+ foreach my $cn (keys(%chanlist)) {
+ open_log("logserv:$cn", lc($cn).'.log');
+ agent_join($lsnick, $cn);
+ ircd::setmode($lsnick, $cn, $chanopmode, $lsnick);
+ }
+}
+
+sub init { }
+sub begin { }
+sub end { }
+sub unload { saveconf(); }
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#
+# Copyright saturn@surrealchat.net
+# multiple feature-adds and code changes tabris@tabris.net
+#
+# Licensed under the GNU Public License
+# http://www.gnu.org/licenses/gpl.txt
+#
+
+package securitybot;
+
+use strict;
+no strict "refs";
+use Time::HiRes qw(gettimeofday);
+
+use SrSv::Process::Init;
+use SrSv::IRCd::Event 'addhandler';
+use SrSv::IRCd::State 'initial_synced';
+use SrSv::Timer qw(add_timer);
+use SrSv::Time;
+use SrSv::Agent;
+use SrSv::HostMask qw( parse_hostmask );
+use SrSv::Conf2Consts qw(main sql);
+use SrSv::SimpleHash qw(readHash writeHash);
+
+use SrSv::Log;
+
+use SrSv::User qw( get_user_nick );
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::MySQL '$dbh';
+use SrSv::MySQL::Glob;
+
+use SrSv::Shared qw(%conf %torip %unwhois);
+
+use SrSv::Process::InParent qw(list_conf loadconf saveconf update_tor_list);
+
+use SrSv::TOR;
+
+#this stuff needs to be put into files
+our $sbnick = "SecurityBot";
+our $ident = 'Security';
+our $gecos = 'Security Monitor (you are being monitored)';
+our $umodes = '+BHSdopqz';
+our $vhost = 'services.SC.bot';
+
+our (
+ $add_spamfilter, $del_spamfilter, $add_tklban, $del_tklban,
+ $del_expired_tklban, $get_expired_tklban,
+
+ $get_tklban, $get_spamfilter,
+ $get_all_tklban, $get_all_spamfilter,
+
+ $check_opm,
+);
+
+loadconf(0);
+our $enabletor = $conf{'EnableTor'};
+register();
+
+addhandler('SEOS', undef, undef, "securitybot::start_timers");
+addhandler('TKL', undef, undef, "securitybot::handle_tkl");
+
+addhandler('PRIVMSG', undef, $sbnick, "securitybot::msghandle");
+addhandler('NOTICE', undef, $sbnick, "securitybot::noticehandle");
+addhandler('SENDSNO', undef, undef, "securitybot::snotice");
+addhandler('GLOBOPS', undef, undef, "securitybot::globops");
+addhandler('SMO', undef, undef, "securitybot::snotice");
+
+if($conf{'EnableTor'} or $conf{'CTCPonConnect'} or $conf{'EnableOPM'}) {
+ addhandler('NICKCONN', undef, undef, 'securitybot::nickconn');
+ addhandler('USERIP', undef, undef, 'securitybot::userip');
+}
+
+proc_init {
+ $add_tklban = $dbh->prepare_cached("REPLACE INTO tklban
+ SET type=?, ident=?, host=?, setter=?, expire=?, time=?, reason=?");
+ $del_tklban = $dbh->prepare_cached("DELETE FROM tklban WHERE type=? AND ident=? AND host=?");
+ $add_spamfilter = $dbh->prepare_cached("REPLACE INTO spamfilter
+ SET target=?, action=?, setter=?, expire=?, time=?, bantime=?, reason=?, mask=?");
+ $del_spamfilter = $dbh->prepare_cached("DELETE FROM spamfilter WHERE target=? AND action=? AND mask=?");
+
+ $del_expired_tklban = $dbh->prepare_cached("DELETE FROM tklban WHERE expire <= UNIX_TIMESTAMP() AND expire!=0");
+ $get_expired_tklban = $dbh->prepare_cached("SELECT type, ident, host, setter, expire, time, reason
+ FROM tklban WHERE expire <= UNIX_TIMESTAMP() AND expire!=0");
+
+ $get_tklban = $dbh->prepare_cached("SELECT setter, expire, time, reason FROM tklban WHERE
+ type=? AND ident=? AND host=?");
+ $get_spamfilter = $dbh->prepare_cached("SELECT time, reason FROM spamfilter WHERE target=? AND action=? AND mask=?");
+
+ $get_all_tklban = $dbh->prepare_cached("SELECT type, ident, host, setter, expire, time, reason
+ FROM tklban ORDER BY type, time, host");
+ $get_all_spamfilter = $dbh->prepare_cached("SELECT target, action, setter, expire, time, bantime, reason, mask, managed
+ FROM spamfilter ORDER BY time, mask");
+
+ $check_opm = $dbh->prepare_cached("SELECT 1 FROM opm WHERE ipaddr=?");
+};
+
+sub init {
+ return if main::COMPILE_ONLY();
+ my $tmpdbh = DBI->connect(
+ "DBI:mysql:".sql_conf_mysql_db,
+ sql_conf_mysql_user,
+ sql_conf_mysql_pass,
+ {
+ AutoCommit => 1,
+ RaiseError => 1
+ }
+ );
+ $tmpdbh->do("TRUNCATE TABLE tklban");
+ $tmpdbh->do("TRUNCATE TABLE spamfilter");
+ $tmpdbh->disconnect();
+}
+
+=cut
+my %snomasks = (
+ e => 'Eyes Notice',
+ v => 'VHost Notice',
+ # They're prefixed already.
+ #S => 'Spamfilter',
+ o => 'Oper-up Notice',
+);
+=cut
+
+sub snotice($$$) {
+ my ($server, $type, $msg) = @_;
+# $type = $snomasks{$type};
+# diagmsg( ($type ? "[$type] " : '').$msg);
+ diagmsg( $msg);
+}
+
+sub globops($$) {
+ my ($src, $msg) = @_;
+ diagmsg("Global -- from $src: $msg");
+}
+
+sub register {
+ agent_connect($sbnick, $ident, undef, $umodes, $gecos);
+ ircd::sqline($sbnick, 'Reserved for Services');
+
+ agent_join($sbnick, main_conf_diag);
+ ircd::setmode($sbnick, main_conf_diag, '+o', $sbnick);
+}
+
+sub start_timers {
+ add_timer('', 5, __PACKAGE__, 'securitybot::start_timers2');
+ expire_tkl_timed();
+}
+
+sub start_timers2 {
+ update_tor_list_timed(3540) if $enabletor;
+ #securitybot::ss2tkl::update_ss_timed(3300) if $conf{'EnableSS'};
+};
+
+sub nickconn {
+ my ($rnick, $time, $ident, $host, $vhost, $server, $modes, $gecos, $ip, $svsstamp) = @_[0,2..4,8,5,7,9,10,6];
+
+ goto OUT if ($svsstamp or $unwhois{lc $rnick});
+
+ if((initial_synced and $enabletor) or $conf{'EnableOPM'} or $conf{'BanCountry'} ) {
+ if ($ip) {
+ check_blacklists($rnick, $ip) or return;
+ }
+ else {
+ ircd::userip($rnick) unless module::is_loaded('services');
+ }
+ }
+
+ if($conf{'CTCPonConnect'}) {
+ my @ctcplist = split(/ /, $conf{'CTCPonConnect'});
+ foreach my $ctcp_msg (@ctcplist) {
+ if(uc($ctcp_msg) eq 'PING') {
+ my ($sec, $usec) = gettimeofday();
+ ircd::ctcp($sbnick, $rnick, 'PING', $sec, $usec);
+ } else {
+ ircd::ctcp($sbnick, $rnick, uc($ctcp_msg));
+ }
+ }
+ }
+ OUT:
+ $unwhois{lc $rnick} = 1 unless ($svsstamp or $ip);
+}
+
+sub userip {
+ my($src, $rnick, $ip) = @_;
+
+ return unless($unwhois{lc $rnick});
+ return unless($ip =~ /^\d{1,3}(\.\d{1,3}){3}$/);
+
+ check_blacklists($rnick, $ip) or return;
+
+ delete $unwhois{lc $rnick};
+}
+
+sub check_opm($) {
+ my ($ip) = @_;
+ $check_opm->execute($ip);
+ my ($ret) = $check_opm->fetchrow_array();
+ $check_opm->finish();
+ return $ret;
+}
+
+sub check_country($) {
+ my ($ip) = @_;
+ my $ccode;
+ if(module::is_loaded('geoip')) {
+ $ccode = geoip::get_ip_location($ip);
+ } elsif(module::is_loaded('country')) {
+ $ccode = country::get_ip_country_aton($ip);
+ }
+ foreach my $country (split(/[, ]+/, $conf{'BanCountry'})) {
+ if (lc $ccode eq lc $country) {
+ return country::get_country_long($country);
+ }
+ }
+ return undef;
+}
+
+sub mk_banreason($$) {
+ my ($reason, $ip) = @_;
+ $reason =~ s/\$/$ip/g;
+ return $reason;
+}
+
+sub check_blacklists($$) {
+ my ($rnick, $ip) = @_;
+
+ if(initial_synced and $enabletor && $torip{$ip}) {
+ if (lc $enabletor eq lc 'vhost') {
+ ircd::chghost($sbnick, $rnick, misc::gen_uuid(1, 20).'.session.tor');
+ } else {
+ ircd::zline($sbnick, $ip, $conf{'ProxyZlineTime'}, $conf{'TorZlineReason'});
+ }
+ return 0;
+ }
+
+ if($conf{'EnableOPM'} && check_opm($ip)) {
+ ircd::zline($sbnick, $ip, $conf{'ProxyZlineTime'}, mk_banreason($conf{'OPMZlineReason'}, $ip));
+ return 0;
+ }
+
+sub hasGeoCountry() {
+ return module::is_loaded('country') || module::is_loaded('geoip');
+}
+
+ if($conf{'BanCountry'} && hasGeoCountry() && (my $country = check_country($ip))) {
+ ircd::zline($sbnick, $ip, $conf{'ProxyZlineTime'}, mk_banreason($conf{'CountryZlineReason'}, $country));
+ return 0;
+ }
+
+ return 1;
+}
+
+sub update_tor_list_timed($) {
+ my $time = shift;
+ $time = 3600 unless $time;
+
+ add_timer('', $time, __PACKAGE__, 'securitybot::update_tor_list_timed');
+
+ update_tor_list() if $enabletor;
+}
+
+sub update_tor_list() {
+ return unless (defined($conf{'TorServer'}) && length($conf{'TorServer'}));
+ diagmsg( " -- Loading Tor server list.");
+
+ # path may be a local one if you run a tor-client.
+ # most configs are /var/lib/tor/cached-directory
+ my %newtorip;
+ foreach my $torIP (getTorRouters($conf{'TorServer'})) {
+ $newtorip{$torIP} = 1;
+ }
+
+ my $torcount = scalar(keys(%newtorip));
+
+ if($torcount > 0) {
+ %torip = %newtorip;
+ diagmsg( " -- Finished loading Tor server list - $torcount servers found.");
+ } else {
+ diagmsg( " -- Failed to load Tor server list, CHECK YOUR TorServer SETTING.");
+ }
+}
+
+sub msghandle {
+ my ($rnick, $dst, $msg) = @_;
+ print join("\n", @_);
+ my $user = { NICK => $rnick, AGENT => $sbnick };
+ unless (adminserv::is_ircop($user)) {
+ notice($user, 'Permission Denied');
+ return;
+ }
+
+ if($msg =~ /^help/i) {
+ my (undef, @args) = split(/ /, $msg); #discards first token 'help'
+ sendhelp($user, 'securitybot', @args);
+ }
+
+ elsif($msg =~ /^notice (\S*) (.*)/i) {
+ ircd::notice($sbnick, $1, $2);
+ }
+
+ elsif($msg =~ /^msg (\S*) (.*)/i) {
+ ircd::privmsg($sbnick, $1, $2);
+ }
+
+ elsif($msg =~ /^raw (.*)/i) {
+ if(!adminserv::is_svsop($user, adminserv::S_ROOT() )) {
+ notice($user, 'You do not have sufficient rank for this command');
+ return;
+ }
+ ircd::ircsend($1);
+ }
+
+ elsif($msg =~ /^kill (\S*) (.*)/i) {
+ ircd::irckill($sbnick, $1, $2);
+ }
+
+ elsif($msg =~ /^conf/i) {
+ notice($user, "Configuration:", list_conf);
+ }
+
+ elsif($msg =~ /^set (\S+) (.*)/i) {
+ if(!adminserv::is_svsop($user, adminserv::S_ROOT() )) {
+ notice($user, 'You do not have sufficient rank for this command');
+ return;
+ }
+
+ my @p = ($1, $2);
+ chomp $p[1];
+
+ if(update_conf($p[0], $p[1])) {
+ notice($user, "Configuration: ".$p[0]." = ".$p[1]);
+ } else {
+ notice($user, "That value is read-only.");
+ }
+ }
+
+ elsif($msg =~ /^save/i) {
+ notice($user, "Saving configuration.");
+
+ saveconf();
+ }
+
+ elsif($msg =~ /^rehash/i) {
+ notice($user, "Loading configuration.");
+
+ loadconf(1);
+ }
+
+ elsif($msg =~ /^tssync/i) {
+ ircd::tssync();
+ }
+
+ elsif($msg =~ /^svsnick (\S+) (\S+)/i) {
+ if(!adminserv::is_svsop($user, adminserv::S_ROOT() )) {
+ notice($user, 'You do not have sufficient rank for this command');
+ return;
+ }
+ ircd::svsnick($sbnick, $1, $2);
+ }
+
+ elsif($msg =~ /^tor-update/i) {
+ notice($user, "Updating Tor server list.");
+ update_tor_list();
+ }
+=cut
+ elsif($msg =~ /^ss-update/i) {
+ notice($user, "Updating SS definitions.");
+ securitybot::ss2tkl::update_ss();
+ }
+=cut
+ elsif($msg =~ /^tkl/i) {
+ sb_tkl($user, $msg);
+ }
+}
+
+sub list_conf() {
+ my @k = keys(%conf);
+ my @v = values(%conf);
+ my @reply;
+
+ for(my $i=0; $i<@k; $i++) {
+ push @reply, $k[$i]." = ".$v[$i];
+ }
+ return @reply;
+}
+
+sub noticehandle {
+ my ($rnick, $dst, $msg) = @_;
+
+ if($msg =~ /^\x01(\S+)\s?(.*?)\x01?$/) {
+ diagmsg( "Got $1 reply from $rnick: $2");
+ }
+}
+
+sub sb_tkl($$) {
+# This function is a hack to fit better our normal services coding style.
+# Better fix is to rewrite msghandle in another cleanup patch.
+ my ($user, $msg) = @_;
+ # We discard first token 'tkl'
+ my $cmd;
+ (undef, $cmd, $msg) = split(/ /, $msg, 3);
+ if(lc($cmd) eq 'list') {
+ if($msg) {
+ sb_tkl_glob($user, $msg);
+ }
+ else {
+ sb_tkl_list($user);
+ }
+ }
+ elsif(lc($cmd) eq 'del') {
+ unless($msg) {
+ notice($user, "You have to specify at least one parameter");
+ }
+ sb_tkl_glob_delete($user, $msg);
+ }
+}
+
+sub sb_tkl_list($) {
+ my ($user) = @_;
+ my @reply;
+ $get_all_tklban->execute();
+ while(my ($type, $ident, $host, $setter, $expire, $time, $reason) = $get_all_tklban->fetchrow_array()) {
+ if($type eq 'Q') {
+ #push @reply, "$type $host $setter";
+ next;
+ }
+ else {
+ push @reply, "$type $ident\@$host $setter";
+ }
+ $time = gmtime2($time); $expire = time_rel($expire - time()) if $expire;
+ push @reply, " set: $time; ".($expire ? "expires in: $expire" : "Will not expire");
+ push @reply, " reason: $reason";
+ }
+ $get_all_tklban->finish();
+ push @reply, "No results" unless @reply;
+
+ notice($user, @reply);
+}
+
+sub sb_tkl_glob($$) {
+ my ($user, $cmdline) = @_;
+
+ my $sql_expr = "SELECT type, ident, host, setter, expire, time, reason FROM tklban ";
+
+ my ($filters, $parms) = split(/ /, $cmdline, 2);
+ my @filters = split(//, $filters);
+ unless($filters[0] eq '+' or $filters[0] eq '-') {
+ notice($user, "Invalid Syntax: First parameter must be a set of filters preceded by a + or -");
+ return;
+ }
+ my @args = misc::parse_quoted($parms);
+
+ my ($success, $expr) = make_tkl_query(\@filters, \@args);
+ unless ($success) {
+ notice($user, "Error: $expr");
+ return;
+ }
+ $sql_expr .= $expr;
+
+ my @reply;
+ my $get_glob_tklban = $dbh->prepare($sql_expr);
+ $get_glob_tklban->execute();
+ while(my ($type, $ident, $host, $setter, $expire, $time, $reason) = $get_glob_tklban->fetchrow_array()) {
+ if($type eq 'Q') {
+ #push @reply, "$type $host $setter";
+ next;
+ }
+ else {
+ push @reply, "$type $ident\@$host $setter";
+ }
+ $time = gmtime2($time); $expire = time_rel($expire - time()) if $expire;
+ push @reply, " set: $time; ".($expire ? "expires in: $expire" : "Will not expire");
+ push @reply, " reason: $reason";
+ }
+ $get_glob_tklban->finish();
+
+ push @reply, "No results" unless @reply;
+ notice($user, @reply);
+}
+
+sub sb_tkl_glob_delete($$) {
+ my ($user, $cmdline) = @_;
+
+ my $sql_expr = "SELECT type, ident, host FROM tklban ";
+
+ my ($filters, $parms) = split(/ /, $cmdline, 2);
+ my @filters = split(//, $filters);
+ unless($filters[0] eq '+' or $filters[0] eq '-') {
+ notice($user, "Invalid Syntax: First parameter must be a set of filters preceded by a + or -");
+ return;
+ }
+ my @args = misc::parse_quoted($parms);
+
+ my ($success, $expr) = make_tkl_query(\@filters, \@args);
+ unless ($success) {
+ notice($user, "Error: $expr");
+ return;
+ }
+
+ $sql_expr .= $expr;
+
+ my $src = get_user_nick($user);
+ my $get_glob_tklban = $dbh->prepare($sql_expr);
+ $get_glob_tklban->execute();
+ while(my ($type, $ident, $host) = $get_glob_tklban->fetchrow_array()) {
+ if($type eq 'G') {
+ ircd::unkline($src, $ident, $host);
+ }
+ elsif($type eq 'Z') {
+ ircd::unzline($src, $host);
+ }
+ }
+ $get_glob_tklban->finish();
+
+}
+
+sub make_tkl_query($$) {
+ my ($parm1, $parm2) = @_;
+ my @filters = @$parm1; my @args = @$parm2;
+
+ my ($sign, $sql_expr, $sortby, $where, $and);
+ while(my $filter = shift @filters) {
+ my $condition;
+ if ($filter eq '+') {
+ $sign = +1;
+ next;
+ }
+ elsif($filter eq '-') {
+ $sign = 0;
+ next;
+ }
+
+ my $parm = shift @args;
+ unless (defined($parm)) {
+ return (0, "Not enough arguments for filters.");
+ }
+ if($filter eq 'm') {
+ my ($mident, $mhost) = parse_hostmask($parm);
+ $mident = glob2sql($dbh->quote($mident)) if $mident;
+ $mhost = glob2sql($dbh->quote($mhost)) if $mhost;
+
+ $condition = ($mident ? ($sign ? '' : '!').
+ "(ident LIKE $mident) " : '').
+ ($mhost ? ($sign ? '' : '!').
+ "(host LIKE $mhost) " : '');
+ }
+ elsif($filter eq 'r') {
+ my $reason = $dbh->quote($parm);
+ $reason = glob2sql($reason);
+ $condition = ($sign ? '' : '!')."(reason LIKE $reason) ";
+
+ }
+ elsif($filter eq 's') {
+ my $setter = $dbh->quote($parm);
+ $setter = glob2sql($setter);
+ $condition = ($sign ? '' : '!')."(setter LIKE $setter) ";
+
+ }
+ if($filter eq 'M') {
+ my ($mident, $mhost) = parse_hostmask($parm);
+ $mident = $dbh->quote($mident) if $mident;
+ $mhost = $dbh->quote($mhost) if $mhost;
+ $condition = ($mident ? ($sign ? '' : '!').
+ "(ident REGEXP $mident) " : '').
+ ($mhost ? ($sign ? '' : '!').
+ "(host REGEXP $mhost) " : '');
+ }
+ elsif($filter eq 'R') {
+ my $reason = $dbh->quote($parm);
+ $condition = ($sign ? '' : '!')."(reason REGEXP $reason) ";
+
+ }
+ elsif($filter eq 'S') {
+ my $setter = $dbh->quote($parm);
+ $condition = ($sign ? '' : '!')."(setter REGEXP $setter) ";
+
+ }
+ elsif(lc $filter eq 'o') {
+ $parm = lc $parm;
+ next unless ($parm =~ /(type|ident|host|setter|expire|reason|time)/);
+ if ($sortby) {
+ $sortby .= ', ';
+ } else {
+ $sortby = 'ORDER BY ';
+ }
+ $sortby .= $parm.($sign ? ' ASC' : ' DESC');
+ next;
+ }
+ if (!$where) {
+ $sql_expr .= 'WHERE ';
+ $where = 1;
+ }
+ if ($and) {
+ $sql_expr .= 'AND ';
+ } else {
+ $and = 1;
+ }
+ $sql_expr .= $condition if $condition;
+ }
+ if (scalar(@args)) {
+ return (0, "Too many arguments for filters.");
+ }
+ return (1, $sql_expr.((defined $sortby and $sortby ne '') ? $sortby : 'ORDER BY type, time, host'));
+}
+
+sub get_tkl_type_name($) {
+ my %tkltype = (
+ G => 'G:line',
+ Z => 'GZ:line',
+ s => 'Shun',
+ Q => 'Q:line',
+ );
+ return $tkltype{$_[0]};
+};
+
+sub get_filter_action_name($) {
+ my %filteraction = (
+ Z => 'GZ:line',
+ S => 'tempshun',
+ s => 'shun',
+ g => 'G:line',
+ z => 'Z:line',
+ k => 'K:line',
+ K => 'Kill',
+ b => 'Block',
+ d => 'DCC Block',
+ v => 'Virus Chan',
+ w => 'Warn',
+ #t => 'Test', # Should never show up, and not implemented in 3.2.4 yet.
+ );
+ return $filteraction{$_[0]};
+};
+
+sub handle_tkl($$@) {
+ my ($type, $sign, @parms) = @_;
+ return unless defined ($dbh);
+ if ($type eq 'G' or $type eq 'Z' or $type eq 's' or $type eq 'Q') {
+ if ($sign == +1) {
+ my ($ident, $host, $setter, $expire, $time, $reason) = @parms;
+ $add_tklban->execute($type, $ident, $host, $setter, $expire, $time, $reason);
+ $add_tklban->finish();
+ diagmsg( get_tkl_type_name($type)." added for $ident\@$host ".
+ "from ($setter on ".gmtime2($time).
+ ($expire ? ' to expire at '.gmtime2($expire) : ' does not expire').": $reason)")
+ if initial_synced() and $type ne 'Q';
+ }
+ elsif($sign == -1) {
+ my ($ident, $host, $setter) = @parms;
+
+ if ($type ne 'Q' and initial_synced()) {
+ $get_tklban->execute($type, $ident, $host);
+ my (undef, $expire, $time, $reason) = $get_tklban->fetchrow_array;
+ $get_tklban->finish();
+
+ diagmsg( "$setter removed ".get_tkl_type_name($type)." $ident\@$host ".
+ "set at ".gmtime2($time)." - reason: $reason");
+ }
+
+ $del_tklban->execute($type, $ident, $host);
+ $del_tklban->finish();
+ }
+ }
+ elsif($type eq 'F') {
+ if($sign == +1) {
+ my ($target, $action, $setter, $expire, $time, $bantime, $reason, $mask) = @parms;
+ $add_spamfilter->execute($target, $action, $setter, $expire, $time, $bantime, $reason, $mask);
+ $add_spamfilter->finish();
+ diagmsg( "Spamfilter added: '$mask' [target: $target] [action: ".
+ get_filter_action_name($action)."] [reason: $reason] on ".gmtime2($time)."from ($setter)")
+ if initial_synced();
+ }
+ elsif($sign == -1) {
+ # TKL - F u Z tabris!northman@tabris.netadmin.SCnet.ops 0 0 :do_not!use@mask
+ my ($target, $action, $setter, $mask) = @parms;
+ if(initial_synced()) {
+ $get_spamfilter->execute($target, $action, $mask);
+ my ($time, $reason) = $get_spamfilter->fetchrow_array;
+ $get_spamfilter->finish();
+ $reason =~ tr/_/ /;
+ diagmsg( "$setter removed Spamfilter (action: ".get_filter_action_name($action).
+ ", targets: $target) (reason: $reason) '$mask' set at: ".gmtime2($time));
+ }
+ $del_spamfilter->execute($target, $action, $mask);
+ $del_spamfilter->finish();
+ }
+ }
+}
+
+sub saveconf() {
+ writeHash(\%conf, "config/securitybot/sb.conf");
+}
+
+sub loadconf($) {
+ my ($update) = @_;
+
+ %conf = readHash("config/securitybot/sb.conf");
+}
+
+sub update_conf($$) {
+ my ($k, $v) = @_;
+
+ return 0 if($k eq 'EnableTor');
+
+ $conf{$k} = $v;
+ return 1;
+}
+
+sub expire_tkl() {
+ $get_expired_tklban->execute();
+ while (my ($type, $ident, $host, $setter, $expire, $time, $reason) = $get_expired_tklban->fetchrow_array()) {
+ if ($type eq 'G' or $type eq 'Z' or $type eq 's') {
+ diagmsg( "Expiring ".get_tkl_type_name($type)." $ident\@$host ".
+ "set by $setter at ".gmtime2($time)." - reason: $reason");
+ #$del_tklban->execute($type, $ident, $host);
+ #$del_tklban->finish();
+ }
+ }
+ $get_expired_tklban->finish();
+
+ $del_expired_tklban->execute();
+ $del_expired_tklban->finish();
+}
+
+sub expire_tkl_timed {
+ my ($time) = @_;
+ $time = 10 unless $time;
+
+ add_timer('10', $time, __PACKAGE__, "securitybot::expire_tkl_timed");
+
+ expire_tkl();
+}
+
+sub diagmsg(@) {
+ ircd::privmsg($sbnick, main_conf_diag, @_);
+ write_log('diag', '<'.main_conf_local.'>', @_);
+}
+
+sub end { }
+sub unload { saveconf(); }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package services;
+use strict;
+
+use SrSv::Conf::services;
+
+use SrSv::MySQL qw($dbh);
+use SrSv::Conf qw(main services sql);
+use SrSv::Conf2Consts qw(main services sql);
+use SrSv::Timer qw(add_timer);
+use SrSv::Agent;
+use SrSv::IRCd::Event qw(addhandler);
+use SrSv::Log;
+use SrSv::User qw( :flood __flood_expire );
+
+use modules::serviceslibs::adminserv;
+use modules::serviceslibs::nickserv;
+use modules::serviceslibs::chanserv;
+use modules::serviceslibs::operserv;
+use modules::serviceslibs::botserv;
+use modules::serviceslibs::memoserv;
+use modules::serviceslibs::hostserv;
+
+*conf = \%services_conf; # only used in some help docs
+
+our @agents = (
+ [$nickserv::nsnick_default, '+opqzBHS', 'Nick Registration Agent'],
+ [$chanserv::csnick_default, '+pqzBS', 'Channel Registration Agent'],
+ [$operserv::osnick_default, '+opqzBHS', 'Operator Services Agent'],
+ [$memoserv::msnick_default, '+pqzBS', 'Memo Exchange Agent'],
+ [$botserv::bsnick_default, '+pqzBS', 'Channel Bot Control Agent'],
+ [$adminserv::asnick_default, '+pqzBS', 'Services\' Administration Agent'],
+ [$hostserv::hsnick_default, '+pqzBS', 'vHost Agent']
+);
+if(services_conf_nickserv) {
+ push @agents, [services_conf_nickserv, '+opqzBHS', 'Nick Registration Agent'];
+ $nickserv::nsnick = services_conf_nickserv;
+}
+if(services_conf_chanserv) {
+ push @agents, [services_conf_chanserv, '+pqzBS', 'Channel Registration Agent'];
+ $chanserv::csnick = services_conf_chanserv;
+}
+if(services_conf_operserv) {
+ push @agents, [services_conf_operserv, '+opqzBHS', 'Operator Services Agent'];
+ $operserv::osnick = services_conf_operserv;
+}
+if(services_conf_memoserv) {
+ push @agents, [services_conf_memoserv, '+pqzBS', 'Memo Exchange Agent'];
+ $memoserv::msnick = services_conf_memoserv;
+}
+if(services_conf_botserv) {
+ push @agents, [services_conf_botserv, '+pqzBS', 'Channel Bot Control Agent'];
+ $botserv::bsnick = services_conf_botserv;
+}
+if(services_conf_adminserv) {
+ push @agents, [services_conf_adminserv, '+pqzBS', 'Services\' Administration Agent'];
+ $adminserv::asnick = services_conf_adminserv;
+}
+if(services_conf_hostserv) {
+ push @agents, [services_conf_hostserv, '+pqzBS', 'vHost Agent'];
+ $hostserv::hsnick = services_conf_hostserv;
+}
+
+our $qlreason = 'Reserved for Services';
+
+foreach my $a (@agents) {
+ agent_connect($a->[0], 'services', undef, $a->[1], $a->[2]);
+ ircd::sqline($a->[0], $qlreason);
+ agent_join($a->[0], main_conf_diag);
+ ircd::setmode($main::rsnick, main_conf_diag, '+o', $a->[0]);
+}
+
+addhandler('SEOS', undef, undef, 'services::ev_connect');
+sub ev_connect {
+ botserv::eos();
+ nickserv::cleanup_users();
+ nickserv::fix_vhosts();
+ chanserv::eos();
+ operserv::expire();
+}
+
+addhandler('EOS', undef, undef, 'services::eos');
+sub eos {
+ chanserv::eos($_[0]);
+}
+
+addhandler('KILL', undef, undef, 'nickserv::killhandle');
+
+addhandler('NICKCONN', undef, undef, 'services::ev_nickconn');
+sub ev_nickconn {
+ nickserv::nick_create(@_[0,2..4,8,5..7,9,10,11]);
+}
+
+# NickServ
+addhandler('NICKCHANGE', undef, undef, 'nickserv::nick_change');
+addhandler('QUIT', undef, undef, 'nickserv::nick_delete');
+addhandler('UMODE', undef, undef, 'nickserv::umode');
+addhandler('CHGHOST', undef, undef, 'nickserv::chghost');
+addhandler('CHGIDENT', undef, undef, 'nickserv::chgident');
+addhandler('USERIP', undef, undef, 'nickserv::userip');
+addhandler('SQUIT', undef, undef, 'nickserv::squit') if ircd::NOQUIT();
+
+addhandler('PRIVMSG', undef, 'nickserv', 'nickserv::dispatch');
+addhandler('PRIVMSG', undef, lc services_conf_nickserv, 'nickserv::dispatch') if services_conf_nickserv;
+
+addhandler('BACK', undef, undef, 'nickserv::notify_auths');
+
+# ChanServ
+addhandler('JOIN', undef, undef, 'chanserv::user_join');
+addhandler('SJOIN', undef, undef, 'chanserv::handle_sjoin');
+addhandler('PART', undef, undef, 'chanserv::user_part');
+addhandler('KICK', undef, undef, 'chanserv::process_kick');
+addhandler('MODE', undef, qr/^#/, 'chanserv::chan_mode');
+addhandler('TOPIC', undef, undef, 'chanserv::chan_topic');
+
+addhandler('PRIVMSG', undef, 'chanserv', 'chanserv::dispatch');
+addhandler('PRIVMSG', undef, lc services_conf_chanserv, 'chanserv::dispatch') if services_conf_chanserv;
+
+# OperServ
+addhandler('PRIVMSG', undef, 'operserv', 'operserv::dispatch');
+addhandler('PRIVMSG', undef, lc services_conf_operserv, 'operserv::dispatch') if services_conf_operserv;
+
+add_timer('flood_expire', 10, __PACKAGE__, 'services::flood_expire');
+
+sub flood_expire(;$) {
+ add_timer('flood_expire', 10, __PACKAGE__, 'services::flood_expire');
+ __flood_expire();
+}
+
+# MemoServ
+addhandler('PRIVMSG', undef, 'memoserv', 'memoserv::dispatch');
+addhandler('PRIVMSG', undef, lc services_conf_memoserv, 'memoserv::dispatch') if services_conf_memoserv;
+addhandler('BACK', undef, undef, 'memoserv::notify');
+
+# BotServ
+addhandler('PRIVMSG', undef, undef, 'botserv::dispatch');
+# botserv takes all PRIVMSG and NOTICEs, so no special dispatch is needed.
+addhandler('NOTICE', undef, qr/^#/, 'botserv::chan_msg');
+
+# AdminServ
+addhandler('PRIVMSG', undef, 'adminserv', 'adminserv::dispatch');
+addhandler('PRIVMSG', undef, lc services_conf_adminserv, 'adminserv::dispatch') if services_conf_adminserv;
+
+add_timer('', 30, __PACKAGE__, 'services::maint');
+#add_timer('', 20, __PACKAGE__, 'nickserv::cleanup_users');
+add_timer('', 60, __PACKAGE__, 'nickserv::expire_silence_timed');
+
+# HostServ
+addhandler('PRIVMSG', undef, 'hostserv', 'hostserv::dispatch');
+addhandler('PRIVMSG', undef, lc services_conf_hostserv, 'hostserv::dispatch') if services_conf_hostserv;
+
+# $nick should be a registered root nick, if applicable
+# $src is the nick or nickid that sent the command
+sub ulog($$$$;$$) {
+ my ($service, $level, $text) = splice(@_, 0, 3);
+
+ my $hostmask = nickserv::get_hostmask($_[0]);
+
+ # TODO - Record this in the database
+
+ wlog($service, $level, "$hostmask - $text");
+}
+
+sub maint {
+ wlog($main::rsnick, LOG_INFO(), " -- Running maintenance routines.");
+ add_timer('', 3600, __PACKAGE__, 'services::maint');
+
+ nickserv::expire();
+ chanserv::expire();
+
+ wlog($main::rsnick, LOG_INFO(), " -- Maintenance routines complete.");
+}
+
+sub init {
+ return if main::COMPILE_ONLY();
+ my $tmpdbh = DBI->connect("DBI:mysql:".sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass, { AutoCommit => 1, RaiseError => 1 });
+
+ $tmpdbh->do("TRUNCATE TABLE chanuser");
+ $tmpdbh->do("TRUNCATE TABLE nickchg");
+ $tmpdbh->do("TRUNCATE TABLE chan");
+ $tmpdbh->do("TRUNCATE TABLE chanban");
+ $tmpdbh->do("UPDATE user SET online=0, quittime=".time());
+
+ $tmpdbh->disconnect;
+}
+
+sub begin {
+ nickserv::init();
+ chanserv::init();
+ operserv::init();
+ botserv::init();
+ adminserv::init();
+ memoserv::init();
+ hostserv::init();
+}
+
+sub end {
+ $dbh->disconnect;
+}
+
+sub unload { }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package adminserv;
+
+use strict;
+
+use SrSv::Agent;
+
+use SrSv::Text::Format qw(columnar);
+use SrSv::Errors;
+
+use SrSv::User qw(get_user_nick get_user_id);
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::Log;
+
+use SrSv::NickReg::Flags qw(NRF_NOHIGHLIGHT nr_chk_flag_user);
+
+use SrSv::MySQL '$dbh';
+
+use constant {
+ S_HELP => 1,
+ S_OPER => 2,
+ S_ADMIN => 3,
+ S_ROOT => 4,
+};
+
+our (%flags, @levels, @defflags, $allflags);
+
+BEGIN {
+# BE CAREFUL CHANGING THESE
+my @flags = (
+ 'SERVOP',
+ 'FJOIN',
+ 'SUPER',
+ 'HOLD',
+ 'FREEZE',
+ 'BOT',
+ 'QLINE',
+ 'KILL',
+ 'HELP',
+);
+
+for(my $i = scalar(@flags) - 1; $i >= 0; $i--) {
+ $flags{$flags[$i]} = 1 << $i;
+}
+$allflags = (1 << scalar(@flags)) - 1;
+our @levels = ('Normal User', 'HelpOp', 'Operator', 'Administrator', 'Root');
+# BE CAREFUL CHANGING THESE
+our @defflags = (
+ 0, # Unused
+ $flags{HELP}, # HelpOp
+ $flags{HELP}|$flags{FJOIN}|$flags{QLINE}|$flags{SUPER}|$flags{FREEZE}|$flags{KILL}, # Operator
+ $flags{HELP}|$flags{FJOIN}|$flags{QLINE}|$flags{SUPER}|$flags{FREEZE}|$flags{KILL}|
+ $flags{HOLD}|$flags{BOT}|$flags{SERVOP}, # Admin
+ $allflags # Root
+);
+
+}
+our $asnick_default = 'AdminServ';
+our $asnick = $asnick_default;
+
+
+our (
+ $create_svsop, $delete_svsop, $rename_svsop,
+
+ $get_svs_list, $get_all_svsops,
+
+ $get_svs_level, $set_svs_level, $get_best_svs_level,
+
+ $chk_pass, $get_pass, $set_pass
+);
+
+sub init() {
+ $create_svsop = $dbh->prepare("INSERT IGNORE INTO svsop SELECT id, NULL, NULL FROM nickreg WHERE nick=?");
+ $delete_svsop = $dbh->prepare("DELETE FROM svsop USING svsop, nickreg WHERE nickreg.nick=? AND svsop.nrid=nickreg.id");
+
+ $get_svs_list = $dbh->prepare("SELECT nickreg.nick, svsop.adder FROM svsop, nickreg WHERE svsop.level=? AND svsop.nrid=nickreg.id ORDER BY nickreg.nick");
+ $get_all_svsops = $dbh->prepare("SELECT nickreg.nick, svsop.level, svsop.adder FROM svsop, nickreg WHERE svsop.nrid=nickreg.id ORDER BY svsop.level, nickreg.nick");
+
+ $get_svs_level = $dbh->prepare("SELECT svsop.level FROM svsop, nickalias WHERE nickalias.alias=? AND svsop.nrid=nickalias.nrid");
+ $set_svs_level = $dbh->prepare("UPDATE svsop, nickreg SET svsop.level=?, svsop.adder=? WHERE nickreg.nick=? AND svsop.nrid=nickreg.id");
+ $get_best_svs_level = $dbh->prepare("SELECT svsop.level, nickreg.nick FROM nickid, nickreg, svsop WHERE nickid.nrid=nickreg.id AND svsop.nrid=nickreg.id AND nickid.id=? ORDER BY level DESC LIMIT 1");
+
+ $chk_pass = $dbh->prepare("SELECT 1 FROM ircop WHERE nick=? AND pass=?");
+ $get_pass = $dbh->prepare("SELECT pass FROM ircop WHERE nick=?");
+ $set_pass = $dbh->prepare("UPDATE ircop SET pass=? WHERE nick=?");
+}
+
+### ADMINSERV COMMANDS ###
+
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT => $dst };
+
+ services::ulog($asnick, LOG_INFO(), "cmd: [$msg]", $user);
+
+ unless(is_svsop($user) or is_ircop($user)) {
+ notice($user, $err_deny);
+ ircd::globops($asnick, "\002$src\002 failed access to $asnick $msg");
+ return;
+ }
+
+ if($cmd =~ /^svsop$/i) {
+ my $cmd2 = shift @args;
+
+ if($cmd2 =~ /^add$/i) {
+ if(@args == 2 and $args[1] =~ /^[aoh]$/i) {
+ as_svs_add($user, $args[0], num_level($args[1]));
+ } else {
+ notice($user, 'Syntax: SVSOP ADD <nick> <A|O|H>');
+ }
+ }
+ elsif($cmd2 =~ /^del$/i) {
+ if(@args == 1) {
+ as_svs_del($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: SVSOP DEL <nick>');
+ }
+ }
+ elsif($cmd2 =~ /^list$/i) {
+ if(@args == 1 and $args[0] =~ /^[raoh]$/i) {
+ as_svs_list($user, num_level($args[0]));
+ } else {
+ notice($user, 'Syntax: SVSOP LIST <R|A|O|H>');
+ }
+ }
+ else {
+ notice($user, 'Syntax: SVSOP <ADD|DEL|LIST> [...]');
+ }
+ }
+ elsif($cmd =~ /^whois$/i) {
+ if(@args == 1) {
+ as_whois($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: WHOIS <nick>');
+ }
+ }
+ elsif($cmd =~ /^help$/i) {
+ sendhelp($user, 'adminserv', @args)
+ }
+ elsif($cmd =~ /^staff$/i) {
+ if(@args == 0) {
+ as_staff($user);
+ }
+ else {
+ notice($user, 'Syntax: STAFF');
+ }
+ }
+ else {
+ notice($user, "Unrecognized command. For help, type: \002/msg adminserv help\002");
+ }
+}
+
+sub as_svs_add($$$) {
+ my ($user, $nick, $level) = @_;
+ my $src = get_user_nick($user);
+
+ my ($root, $oper) = validate_chg($user, $nick);
+ return unless $oper;
+
+ if(get_svs_level($root) >= S_ROOT) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ $create_svsop->execute($root);
+ $set_svs_level->execute($level, $oper, $root);
+
+ notice($user, "\002$nick\002 is now a \002Services $levels[$level]\002.");
+ wlog($asnick, LOG_INFO(), "$src added $root as a Services $levels[$level].");
+}
+
+sub as_svs_del($$) {
+ my ($user, $nick) = @_;
+ my $src = get_user_nick($user);
+
+ my ($root, $oper) = validate_chg($user, $nick);
+ return unless $oper;
+
+ if(get_svs_level($root) >= S_ROOT) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ $delete_svsop->execute($root);
+ notice($user, "\002$nick\002 has been stripped of services rank.");
+ wlog($asnick, LOG_INFO(), "$src stripped $root of services rank.")
+}
+
+sub as_svs_list($$) {
+ my ($user, $level) = @_;
+ my (@data, @reply);
+
+ $get_svs_list->execute($level);
+
+ while(my ($nick, $adder) = $get_svs_list->fetchrow_array) {
+ push @data, [$nick, "($adder)"];
+ }
+
+ notice($user, columnar({TITLE => "Services $levels[$level] list:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data));
+}
+
+sub as_whois($$) {
+ my ($user, $nick) = @_;
+
+ my ($level, $root) = get_best_svs_level({ NICK => $nick });
+ notice($user, "\002$nick\002 is a Services $levels[$level]".($level ? ' due to identification to the nick '."\002$root\002." : ''));
+}
+
+sub as_staff($) {
+ my ($user) = @_;
+ my (@data);
+
+ $get_all_svsops->execute();
+
+ while(my ($nick, $level, $adder) = $get_all_svsops->fetchrow_array) {
+ push @data, [$nick, $levels[$level], "($adder)"];
+ }
+
+ notice($user, columnar({TITLE => 'Staff list:',
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data));
+}
+
+
+### DATABASE UTILITY FUNCTIONS ###
+
+sub validate_chg($$) {
+ my ($user, $nick) = @_;
+ my ($oper);
+
+ unless($oper = is_svsop($user, S_ROOT)) {
+ notice($user, $err_deny);
+ return undef;
+ }
+
+ my $root = nickserv::get_root_nick($nick);
+ unless($root) {
+ notice($user, "The nick \002$nick\002 is not registered.");
+ return undef;
+ }
+
+ return ($root, $oper);
+}
+
+sub can_do($$) {
+ my ($user, $flag) = @_;
+ my $nflag = $flags{$flag};
+
+ my ($level, $nick) = get_best_svs_level($user);
+
+ if($defflags[$level] & $nflag) {
+ return $nick if (($nflag == $flags{'HELP'}) or is_ircop($user));
+ }
+
+ return undef;
+}
+
+sub is_svsop($;$) {
+ my ($user, $rlev) = @_;
+
+ my ($level, $nick) = get_best_svs_level($user);
+ return $nick if(defined($level) and !defined($rlev));
+
+ if($level >= $rlev) {
+ return $nick if (($rlev == S_HELP) or is_ircop($user));
+ }
+
+ return undef;
+}
+
+sub is_ircop($) {
+ my ($user) = @_;
+
+ return undef if is_agent($user->{NICK});
+
+ return $user->{IRCOP} if(exists($user->{IRCOP}));
+
+ my %umodes = modes::splitumodes(nickserv::get_user_modes($user));
+
+ no warnings 'deprecated';
+ if(($umodes{'o'} eq '+') or ($umodes{'S'} eq '+')) {
+ $user->{IRCOP} = 1;
+ }
+ else {
+ $user->{IRCOP} = 0;
+ }
+
+ return $user->{IRCOP};
+}
+
+sub is_service($) {
+# detect if a user belongs to another service like NeoStats. only works if they set umode +S
+# is_ircop() includes is_service(), so no reason to call both.
+ my ($user) = @_;
+
+ return undef if is_agent($user->{NICK});
+
+ return $user->{SERVICE} if(exists($user->{SERVICE}));
+
+ my %umodes = modes::splitumodes(nickserv::get_user_modes($user));
+
+ if($umodes{'S'} eq '+') {
+ $user->{SERVICE} = 1;
+ $user->{IRCOP} = 1;
+ }
+ else {
+ $user->{SERVICE} = 0;
+ }
+
+ return $user->{SERVICE};
+}
+
+sub get_svs_level($) {
+ my ($nick) = @_;
+
+ return undef if is_agent($nick);
+
+ $get_svs_level->execute($nick);
+ my ($level) = $get_svs_level->fetchrow_array;
+
+ return $level or 0;
+}
+
+sub get_best_svs_level($) {
+ my ($user) = @_;
+
+ return undef if is_agent($user->{NICK});
+
+ if(exists($user->{SVSOP_LEVEL}) && exists($user->{SVSOP_NICK})) {
+ if(wantarray) {
+ return ($user->{SVSOP_LEVEL}, $user->{SVSOP_NICK});
+ } else {
+ return $user->{SVSOP_LEVEL};
+ }
+ }
+
+ my $uid = get_user_id($user);
+ $get_best_svs_level->execute($uid);
+ my ($level, $nick) = $get_best_svs_level->fetchrow_array;
+
+ $user->{SVSOP_LEVEL} = $level; $user->{SVSOP_NICK} = $nick;
+
+ if(wantarray) {
+ return ($level, $nick);
+ } else {
+ return $level;
+ }
+}
+
+### MISCELLANEA ###
+
+sub num_level($) {
+ my ($x) = @_;
+ $x =~ tr/hoarHOAR/12341234/;
+ return $x;
+}
+
+### IRC EVENTS ###
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package botserv;
+
+use strict;
+no strict 'refs';
+
+use Safe;
+
+use SrSv::Agent;
+use SrSv::Process::Worker 'ima_worker'; #FIXME
+
+use SrSv::Text::Format qw(columnar);
+use SrSv::Errors;
+
+use SrSv::Conf2Consts qw( main services );
+
+use SrSv::User qw(get_user_nick get_user_id :flood);
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::ChanReg::Flags;
+use SrSv::NickReg::Flags qw(NRF_NOHIGHLIGHT nr_chk_flag_user);
+
+use SrSv::MySQL '$dbh';
+
+use constant {
+ F_PRIVATE => 1,
+ F_DEAF => 2
+};
+
+our $bsnick_default = 'BotServ';
+our $bsnick = $bsnick_default;
+our $botchmode;
+if(!ircd::PREFIXAQ_DISABLE()) {
+ $botchmode = '+q';
+} else {
+ $botchmode = '+qo';
+}
+
+*agent = \&chanserv::agent;
+
+our $calc_safe = new Safe;
+
+our (
+ $get_all_bots, $get_botchans, $get_botstay_chans, $get_chan_bot, $get_bots_chans, $get_bot_info,
+
+ $create_bot, $delete_bot, $delete_bot_allchans, $assign_bot, $unassign_bot,
+ $change_bot, $update_chanreg_bot,
+
+ $is_bot, $has_bot,
+
+ $set_flag, $unset_flag, $get_flags
+);
+
+sub init() {
+ $get_all_bots = $dbh->prepare("SELECT nick, ident, vhost, gecos, flags FROM bot");
+ $get_botchans = $dbh->prepare("SELECT chan, COALESCE(bot, '$chanserv::csnick') FROM chanreg WHERE bot != '' OR (flags & ". CRF_BOTSTAY() . ")");
+ $get_botstay_chans = $dbh->prepare("SELECT chan, COALESCE(bot, '$chanserv::csnick') FROM chanreg WHERE (flags & ".
+ CRF_BOTSTAY() . ")");
+ $get_chan_bot = $dbh->prepare("SELECT bot FROM chanreg WHERE chan=?");
+ $get_bots_chans = $dbh->prepare("SELECT chan FROM chanreg WHERE bot=?");
+ $get_bot_info = $dbh->prepare("SELECT nick, ident, vhost, gecos, flags FROM bot WHERE nick=?");
+
+ $create_bot = $dbh->prepare("INSERT INTO bot SET nick=?, ident=?, vhost=?, gecos=?");
+ $delete_bot = $dbh->prepare("DELETE FROM bot WHERE nick=?");
+ $delete_bot_allchans = $dbh->prepare("UPDATE chanreg SET bot='' WHERE bot=?");
+ $change_bot = $dbh->prepare("UPDATE bot SET nick=?, ident=?, vhost=?, gecos=? WHERE nick=?");
+ $update_chanreg_bot = $dbh->prepare("UPDATE chanreg SET bot=? WHERE bot=?");
+
+ $assign_bot = $dbh->prepare("UPDATE chanreg, bot SET chanreg.bot=bot.nick WHERE bot.nick=? AND chan=?");
+ $unassign_bot = $dbh->prepare("UPDATE chanreg SET chanreg.bot='' WHERE chan=?");
+
+ $is_bot = $dbh->prepare("SELECT 1 FROM bot WHERE nick=?");
+ $has_bot = $dbh->prepare("SELECT 1 FROM chanreg WHERE chan=? AND bot != ''");
+
+ $set_flag = $dbh->prepare("UPDATE bot SET flags=(flags | (?)) WHERE nick=?");
+ $unset_flag = $dbh->prepare("UPDATE bot SET flags=(flags & ~(?)) WHERE nick=?");
+ $get_flags = $dbh->prepare("SELECT flags FROM bot WHERE bot.nick=?");
+
+ register() unless ima_worker; #FIXME
+};
+
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+
+ if(lc $dst eq lc $bsnick or lc $dst eq lc $bsnick_default ) {
+ bs_dispatch($src, $dst, $msg);
+ }
+ elsif($dst =~ /^#/) {
+ if($msg =~ /^\!/) {
+ $has_bot->execute($dst);
+ return unless($has_bot->fetchrow_array);
+ chan_dispatch($src, $dst, $msg);
+ } else {
+ chan_msg($src, $dst, $msg);
+ }
+ }
+ else {
+ $is_bot->execute($dst);
+ if($is_bot->fetchrow_array) {
+ bot_dispatch($src, $dst, $msg);
+ }
+ }
+}
+
+### BOTSERV COMMANDS ###
+
+sub bs_dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT => $dst };
+
+ return if flood_check($user);
+
+ if($cmd =~ /^assign$/i) {
+ if (@args == 2) {
+ bs_assign($user, {CHAN => $args[0]}, $args[1]);
+ } else {
+ notice($user, 'Syntax: ASSIGN <#channel> <bot>');
+ }
+ }
+ elsif ($cmd =~ /^unassign$/i) {
+ if (@args == 1) {
+ bs_assign($user, {CHAN => $args[0]}, '');
+ } else {
+ notice($user, 'Syntax: UNASSIGN <#channel>');
+ }
+ }
+ elsif ($cmd =~ /^list$/i) {
+ if(@args == 0) {
+ bs_list($user);
+ } else {
+ notice($user, 'Syntax: LIST');
+ }
+ }
+ elsif ($cmd =~ /^add$/i) {
+ if (@args >= 4) {
+ @args = split(/\s+/, $msg, 5);
+ bs_add($user, $args[1], $args[2], $args[3], $args[4]);
+ } else {
+ notice($user, 'Syntax: ADD <nick> <ident> <vhost> <realname>');
+ }
+ }
+ elsif ($cmd =~ /^change$/i) {
+ if (@args >= 4) {
+ @args = split(/\s+/, $msg, 6);
+ bs_change($user, $args[1], $args[2], $args[3], $args[4], $args[5]);
+ } else {
+ notice($user, 'Syntax: ADD <oldnick> <nick> <ident> <vhost> <realname>');
+ }
+ }
+ elsif ($cmd =~ /^del(ete)?$/i) {
+ if (@args == 1) {
+ bs_del($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: DEL <botnick>');
+ }
+ }
+ elsif($cmd =~ /^set$/i) {
+ if(@args == 3) {
+ bs_set($user, $args[0], $args[1], $args[2]);
+ } else {
+ notice($user, 'Syntax: SET <botnick> <option> <value>');
+ }
+ }
+ elsif($cmd =~ /^seen$/i) {
+ if(@args >= 1) {
+ nickserv::ns_seen($user, @args);
+ } else {
+ notice($user, 'Syntax: SEEN <nick> [nick ...]');
+ }
+ }
+
+ elsif($cmd =~ /^(say|act)$/i) {
+ if(@args > 1) {
+ my @args = split(/\s+/, $msg, 3);
+ my $botmsg = $args[2];
+ $botmsg = "\001ACTION $botmsg\001" if(lc $cmd eq 'act');
+ bot_say($user, {CHAN => $args[1]}, $botmsg);
+ } else {
+ notice($user, 'Syntax: '.uc($cmd).' <#chan> <message>');
+ }
+ }
+ elsif($cmd =~ /^info$/i) {
+ if(@args == 1) {
+ bs_info($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: INFO <botnick>');
+ }
+ }
+ elsif($cmd =~ /^help$/i) {
+ sendhelp($user, 'botserv', @args);
+ }
+ elsif($cmd =~ /^d(ice)?$/i) {
+ notice($user, get_dice($args[0]));
+ }
+ else {
+ notice($user, "Unrecognized command. For help, type: \002/bs help\002");
+ }
+}
+
+# For unassign, set $bot to ''
+#
+sub bs_assign($$$) {
+ my ($user, $chan, $bot) = @_;
+
+ chanserv::chk_registered($user, $chan) or return;
+
+ unless (chanserv::can_do($chan, 'BotAssign', $user)) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if ($bot) {
+ $is_bot->execute($bot);
+ unless($is_bot->fetchrow_array) {
+ notice($user, "\002$bot\002 is not a bot.");
+ return;
+ }
+ }
+
+ $get_flags->execute($bot);
+ my ($botflags) = $get_flags->fetchrow_array;
+ if (($botflags & F_PRIVATE) && !adminserv::can_do($user, 'BOT')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+
+ my $cn = $chan->{CHAN};
+ my $src = get_user_nick($user);
+ my $oldbot;
+ if ($oldbot = get_chan_bot($chan)) {
+ agent_part($oldbot, $cn, "Unassigned by \002$src\002.");
+ }
+
+
+
+ if($bot) {
+ $assign_bot->execute($bot, $cn);
+ bot_join($chan, $bot);
+ notice($user, "\002$bot\002 now assigned to \002$cn\002.");
+ } else {
+ $unassign_bot->execute($cn);
+ notice($user, "\002$oldbot\002 removed from \002$cn\002.");
+ }
+}
+
+sub bs_list($) {
+ my ($user) = @_;
+ my @data;
+ my $is_oper = adminserv::is_svsop($user, adminserv::S_HELP());
+
+ $get_all_bots->execute();
+ while (my ($botnick, $botident, $bothost, $botgecos, $flags) = $get_all_bots->fetchrow_array) {
+ if($is_oper) {
+ push @data, [$botnick, "($botident\@$bothost)", $botgecos,
+ (($flags & F_PRIVATE) ? "Private":"Public")];
+ } else {
+ next if($flags & F_PRIVATE);
+ push @data, [$botnick, "($botident\@$bothost)", $botgecos];
+ }
+ }
+
+ notice($user, columnar({TITLE => "The following bots are available:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data));
+}
+
+sub bs_add($$$$$) {
+ my ($user, $botnick, $botident, $bothost, $botgecos) = @_;
+
+ unless (adminserv::can_do($user, 'BOT')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if (my $ret = is_invalid_agentname($botnick, $botident, $bothost)) {
+ notice($user, $ret);
+ return;
+ }
+
+ if(nickserv::is_registered($botnick)) {
+ notice($user, "The nick \002$botnick\002 is already registered.");
+ return;
+ }
+
+ if(nickserv::is_online($botnick)) {
+ notice($user, "The nick \002$botnick\002 is currently in use.");
+ return;
+ }
+
+ $is_bot->execute($botnick);
+ if($is_bot->fetchrow_array) {
+ notice($user, "\002$botnick\002 already exists.");
+ return;
+ }
+
+ $create_bot->execute($botnick, $botident, $bothost, $botgecos);
+ ircd::sqline($botnick, $services::qlreason);
+ agent_connect($botnick, $botident, $bothost, '+pqBSrz', $botgecos);
+ agent_join($botnick, main_conf_diag);
+ ircd::setmode($main::rsnick, main_conf_diag, '+h', $botnick);
+
+ notice($user, "Bot $botnick connected.");
+}
+
+sub bs_del($$) {
+ my ($user, $botnick) = @_;
+
+ unless (adminserv::can_do($user, 'BOT')) {
+ notice($user, $err_deny);
+ return;
+ }
+ $is_bot->execute($botnick);
+ if (!$is_bot->fetchrow_array) {
+ notice($user, "\002$botnick\002 is not a bot.");
+ return;
+ }
+
+ my $src = get_user_nick($user);
+ $delete_bot->execute($botnick);
+ agent_quit($botnick, "Deleted by \002$src\002.");
+ ircd::unsqline($botnick);
+
+ $delete_bot_allchans->execute($botnick);
+ notice($user, "Bot \002$botnick\002 disconnected.");
+}
+
+sub bs_set($$$$) {
+ my ($user, $botnick, $set, $parm) = @_;
+
+ unless (adminserv::can_do($user, 'BOT')) {
+ notice($user, $err_deny);
+ return;
+ }
+ if($set =~ /^private$/i) {
+ if ($parm =~ /^(on|true)$/i) {
+ set_flag($botnick, F_PRIVATE());
+ notice($user, "\002$botnick\002 is now private.");
+ }
+ elsif ($parm =~ /^(off|false)$/i) {
+ unset_flag($botnick, F_PRIVATE());
+ notice($user, "\002$botnick\002 is now public.");
+ }
+ else {
+ notice($user, 'Syntax: SET <botnick> PRIVATE <ON|OFF>');
+ }
+ }
+ if($set =~ /^deaf$/i) {
+ if ($parm =~ /^(on|true)$/i) {
+ set_flag($botnick, F_DEAF());
+ setagent_umode($botnick, '+d');
+ notice($user, "\002$botnick\002 is now deaf.");
+ }
+ elsif ($parm =~ /^(off|false)$/i) {
+ unset_flag($botnick, F_DEAF());
+ setagent_umode($botnick, '-d');
+ notice($user, "\002$botnick\002 is now undeaf.");
+ }
+ else {
+ notice($user, 'Syntax: SET <botnick> DEAF <ON|OFF>');
+ }
+ }
+}
+
+sub bs_info($$) {
+ my ($user, $botnick) = @_;
+
+ unless (adminserv::can_do($user, 'HELP')) {
+ notice($user, $err_deny);
+ return;
+ }
+ $is_bot->execute($botnick);
+ unless($is_bot->fetchrow_array) {
+ notice($user, "\002$botnick\002 is not a bot.");
+ return;
+ }
+
+ $get_bot_info->execute($botnick);
+ my ($nick, $ident, $vhost, $gecos, $flags) = $get_bot_info->fetchrow_array;
+ $get_bot_info->finish();
+ $get_bots_chans->execute($botnick);
+ my @chans = ();
+ while (my $chan = $get_bots_chans->fetchrow_array) {
+ push @chans, $chan;
+ }
+ $get_bots_chans->finish();
+
+ notice($user, columnar({TITLE => "Information for bot \002$nick\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)},
+ ['Mask:', "$ident\@$vhost"], ['Realname:', $gecos],
+ ['Flags:', (($flags & F_PRIVATE())?'Private ':'').(($flags & F_DEAF())?'Deaf ':'')],
+ {COLLAPSE => [
+ 'Assigned to '. @chans.' channel(s):',
+ ' ' . join(' ', @chans)
+ ]}
+ ));
+}
+
+sub bs_change($$$$$$) {
+ my ($user, $oldnick, $botnick, $botident, $bothost, $botgecos) = @_;
+
+ if (lc $oldnick eq lc $botnick) {
+ notice($user, "Error: $oldnick is the same (case-insensitive) as $botnick",
+ "At this time, you cannot change only the ident, host, gecos, or nick-case of a bot.");
+ return;
+ }
+
+ unless (adminserv::can_do($user, 'BOT')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if (my $ret = is_invalid_agentname($botnick, $botident, $bothost)) {
+ notice($user, $ret);
+ return;
+ }
+
+ if(nickserv::is_registered($botnick)) {
+ notice($user, "The nick \002$botnick\002 is already registered.");
+ return;
+ }
+
+ if(nickserv::is_online($botnick)) {
+ notice($user, "The nick \002$botnick\002 is currently in use.");
+ return;
+ }
+
+ $is_bot->execute($botnick);
+ if($is_bot->fetchrow_array) {
+ notice($user, "\002$botnick\002 already exists.");
+ return;
+ }
+
+ #Create bot first, join it to its chans
+ # then finally delete the old bot
+ # This is to prevent races.
+ $create_bot->execute($botnick, $botident, $bothost, $botgecos);
+ ircd::sqline($botnick, $services::qlreason);
+ agent_connect($botnick, $botident, $bothost, '+pqBSrz', $botgecos);
+ agent_join($botnick, main_conf_diag);
+ ircd::setmode($main::rsnick, main_conf_diag, '+h', $botnick);
+
+ notice($user, "Bot $botnick connected.");
+
+ $get_bots_chans->execute($oldnick);
+ while(my ($cn) = $get_bots_chans->fetchrow_array()) {
+ my $chan = { CHAN => $cn };
+ bot_join($chan, $botnick)
+ if chanserv::get_user_count($chan) or cr_chk_flag($chan, CRF_BOTSTAY(), 1);
+ }
+ $get_bots_chans->finish();
+
+ $update_chanreg_bot->execute($botnick, $oldnick); $update_chanreg_bot->finish();
+
+ my $src = get_user_nick($user);
+ $delete_bot->execute($oldnick);
+ agent_quit($oldnick, "Deleted by \002$src\002.");
+ ircd::unsqline($oldnick);
+ notice($user, "Bot \002$oldnick\002 disconnected.");
+}
+
+### CHANNEL COMMANDS ###
+
+sub chan_dispatch($$$) {
+ my ($src, $cn, $msg) = @_;
+
+ my @args = split(/\s+/, $msg);
+ my $cmd = lc(shift @args);
+ $cmd =~ s/^\!//;
+
+ my $chan = { CHAN => $cn };
+ my $user = { NICK => $src, AGENT => agent($chan) };
+
+ my %cmdhash = (
+ 'voice' => \&give_ops,
+ 'devoice' => \&give_ops,
+ 'hop' => \&give_ops,
+ 'halfop' => \&give_ops,
+ 'dehop' => \&give_ops,
+ 'dehalfop' => \&give_ops,
+ 'op' => \&give_ops,
+ 'deop' => \&give_ops,
+ 'protect' => \&give_ops,
+ 'admin' => \&give_ops,
+ 'deprotect' => \&give_ops,
+ 'deadmin' => \&give_ops,
+
+ 'up' => \&up,
+
+ 'down' => \&down,
+ 'molest' => \&down,
+
+ 'invite' => \&invite,
+
+ 'kick' => \&kick,
+ 'k' => \&kick,
+
+ 'kb' => \&kickban,
+ 'kickb' => \&kickban,
+ 'kban' => \&kickban,
+ 'kickban' => \&kickban,
+ 'bk' => \&kickban,
+ 'bkick' => \&kickban,
+ 'bank' => \&kickban,
+ 'bankick' => \&kickban,
+
+ 'kickmask' => \&kickmask,
+ 'km' => \&kickmask,
+ 'kmask' => \&kickmask,
+
+ 'kickbanmask' => \&kickbanmask,
+ 'kickbmask' => \&kickbanmask,
+ 'kickbm' => \&kickbanmask,
+ 'kbm' => \&kickbanmask,
+ 'kbanm' => \&kickbanmask,
+ 'kbanmask' => \&kickbanmask,
+ 'kbmask' => \&kickbanmask,
+
+ 'calc' => \&calc,
+
+ 'seen' => \&seen,
+
+ #We really need something that is mostly obvious
+ # and won't be used by any other bots.
+ #TriviaBot I added !trivhelp
+ # I guess anope uses !commands
+ 'help' => \&help,
+ 'commands' => \&help,
+ 'botcmds' => \&help,
+
+ 'abbrevs' => \&help,
+ 'abbreviations' => \&help,
+ 'abbrev' => \&help,
+
+ 'users' => \&alist,
+ 'alist' => \&alist,
+
+ 'unban' => \&unban,
+
+ 'banlist' => \&banlist,
+ 'blist' => \&banlist,
+
+ 'ban' => \&ban,
+ 'b' => \&ban,
+ 'qban' => \&ban,
+ 'nban' => \&ban,
+
+ 'd' => \&dice,
+ 'dice' => \&dice,
+
+ 'mode' => \&mode,
+ 'm' => \&mode,
+
+ 'resync' => \&resync,
+
+ 'topic' => \&topic,
+ 't' => \&topic,
+
+ 'why' => \&why,
+ 'tempban' => \&tempban,
+ 'tmpban' => \&tempban,
+ "tb" => \&tempban,
+ );
+
+ sub give_ops {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ chanserv::cs_setmodes($user, $cmd, $chan, @args);
+ }
+ sub up {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ chanserv::cs_updown($user, $cmd, $chan->{CHAN}, @args);
+ }
+ sub down {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ if(lc $cmd eq 'molest') {
+ chanserv::unset_modes($user, $chan);
+ } else {
+ chanserv::cs_updown($user, $cmd, $chan->{CHAN}, @args);
+ }
+ }
+
+ sub invite {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ chanserv::cs_invite($user, $chan, @args) unless @args == 0;
+ }
+
+ sub kick {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ my $target = shift @args or return;
+ chanserv::cs_kick($user, $chan, $target, 0, join(' ', @args));
+ }
+ sub tempban {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+
+ my $cn = $chan->{CHAN};
+ use Data::Dumper;
+
+ unshift @args, $cn;
+ print ("ARGS " . Dumper (@args));
+ chanserv::cs_tempban($user, join(' ', @args));
+ }
+ sub kickban {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ my $target = shift @args or return;
+ chanserv::cs_kick($user, $chan, $target, 1, join(' ', @args));
+ }
+
+ sub kickmask {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ my $target = shift @args or return;
+ chanserv::cs_kickmask($user, $chan, $target, 0, join(' ', @args));
+ }
+ sub kickbanmask {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ my $target = shift @args or return;
+ chanserv::cs_kickmask($user, $chan, $target, 1, join(' ', @args));
+ }
+
+ sub calc {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ my $msg = join(' ', @args);
+ for ($msg) {
+ s/,/./g;
+ s/[^*.+0-9&|)(x\/^-]//g;
+ s/([*+\\.\/x-])\1*/$1/g;
+ s/\^/**/g;
+ s/(?<!0)x//g;
+ }
+
+ my $answer = $calc_safe->reval("($msg) || 0");
+ $answer = 'ERROR' unless defined $answer;
+
+ notice($user, ($@ ? "$msg = ERROR (${\ (split / at/, $@, 2)[0]})" : "$msg = $answer"));
+ }
+
+ sub seen {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+
+ if(@args >= 1) {
+ nickserv::ns_seen($user, @args);
+ } else {
+ notice($user, 'Syntax: SEEN <nick> [nick ...]');
+ }
+ }
+
+ sub help {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ if($cmd =~ /^abbrev(iation)?s?$/) {
+ sendhelp($user, 'chanbot', 'abbreviations');
+ } else {
+ sendhelp($user, 'chanbot');
+ }
+ }
+
+ sub alist {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ chanserv::cs_alist($user, $chan);
+ }
+
+ sub unban {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ if(@args == 0) {
+ chanserv::cs_unban($user, $chan, get_user_nick($user));
+ }
+ elsif(@args >= 1) {
+ chanserv::cs_unban($user, $chan, @args);
+ }
+ }
+
+ sub ban {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ $cmd =~ /^(q|n)?ban$/; my $type = $1;
+ if(@args >= 1) {
+ chanserv::cs_ban($user, $chan, $type, @args);
+ }
+ }
+
+ sub banlist {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ chanserv::cs_banlist($user, $chan);
+ }
+
+ sub dice {
+ # FIXME: If dice is disabled, don't count towards flooding.
+ my ($user, $chan, $cmd, undef, @args) = @_;
+
+ if(chanserv::can_do($chan, 'DICE', $user)) {
+ ircd::privmsg(agent($chan), $chan->{CHAN},
+ get_dice($args[0]));
+ }
+ }
+
+ sub mode {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+ if(@args >= 1) {
+ chanserv::cs_mode($user, $chan, shift @args, @args);
+ }
+ }
+
+ sub resync {
+ my ($user, $chan, $cmd) = @_;
+ chanserv::cs_resync($user, $chan->{CHAN});
+ }
+
+ sub topic {
+ my ($user, $chan, $cmd, $msg) = @_;
+ if (@args >= 1) {
+ $msg =~ s/^!$cmd //;
+ chanserv::cs_topic($user, $chan, $msg);
+ }
+ }
+
+ sub why {
+ my ($user, $chan, $cmd, undef, @args) = @_;
+
+ if(@args >= 1) {
+ chanserv::cs_why($user, $chan, @args);
+ } else {
+ notice($user, 'Syntax: WHY <nick> [nick ...]');
+ }
+ }
+ if(defined($cmdhash{$cmd})) {
+ return if flood_check($user);
+
+ &{$cmdhash{$cmd}}($user, $chan, $cmd, $msg, @args);
+ }
+}
+
+sub bot_say($$$) {
+ my ($user, $chan, $botmsg) = @_;
+ my $cn = $chan->{CHAN};
+
+ if(chanserv::can_do($chan, 'BotSay', $user)) {
+ ircd::notice(agent($chan), '%'.$cn, get_user_nick($user).' used BotSay')
+ if cr_chk_flag($chan, CRF_VERBOSE());
+ ircd::privmsg(agent($chan), $cn, $botmsg);
+ } else {
+ # can_do will give the $err_deny for us.
+ #notice($user, $err_deny);
+ }
+}
+
+### BOT COMMANDS ###
+
+sub bot_dispatch($$$) {
+ my ($src, $bot, $msg) = @_;
+
+ my ($cmd, $cn, $botmsg) = split(/ /, $msg, 3);
+
+ my $user = { NICK => $src, AGENT => $bot };
+ my $chan = { CHAN => $cn };
+
+ return if flood_check($user);
+
+ if ($cmd =~ /^join$/i) {
+ if (adminserv::can_do($user, 'BOT')) {
+ agent_join($bot, $cn);
+ } else {
+ notice($user, $err_deny);
+ }
+ }
+ elsif ($cmd =~ /^part$/i) {
+ if (adminserv::can_do($user, 'BOT')) {
+ agent_part($bot, $cn, "$src requested part");
+ } else {
+ notice($user, $err_deny);
+ }
+ }
+ elsif ($cmd =~ /^say$/i) {
+ bot_say($user, $chan, $botmsg);
+ }
+ elsif ($cmd =~ /^act$/i) {
+ bot_say($user, $chan, "\001ACTION $botmsg\001");
+ }
+ elsif ($cmd =~ /^help$/i) {
+ #my @help; @help = ($cn) if $cn; push @help, split(/\s+/, $botmsg);
+ sendhelp($user, 'botpriv');
+ }
+}
+
+sub get_dice($) {
+ my ($count, $sides) = map int($_), ($_[0] ? split('d', $_[0]) : (1, 6));
+
+ if ($sides < 1 or $sides > 1000 or $count < 0 or $count > 100) {
+ return "Sorry, you can't have more than 100 dice, or 1000 sides, or less than 1 of either.";
+ }
+ $count = 1 if $count == 0;
+
+ my $sum = 0;
+
+ if($count == 1 or $count > 25) {
+ for(my $i = 1; $i <= $count; $i++) {
+ $sum += int(rand($sides)+1);
+ }
+
+ return "${count}d$sides: $sum";
+ }
+ else {
+ my @dice;
+
+ for(my $i = 1; $i <= $count; $i++) {
+ my $n = int(rand($sides)+1);
+ $sum += $n;
+ push @dice, $n;
+ }
+
+ return "${count}d$sides: $sum [" . join(' ', sort {$a <=> $b} @dice) . "]";
+ }
+}
+
+### IRC EVENTS ###
+
+sub chan_msg($$$) {
+ #We don't do chanmsg processing yet, like badwords.
+}
+
+sub register() {
+ $get_all_bots->execute();
+ while(my ($nick, $ident, $vhost, $gecos, $flags) = $get_all_bots->fetchrow_array) {
+ agent_connect($nick, $ident, $vhost, '+pqBSrz'.(($flags & F_DEAF())?'d':''), $gecos);
+ ircd::sqline($nick, $services::qlreason);
+ agent_join($nick, main_conf_diag);
+ ircd::setmode($main::rsnick, main_conf_diag, '+h', $nick);
+ }
+}
+
+sub eos() {
+ $get_botchans->execute();
+ while(my ($cn, $nick) = $get_botchans->fetchrow_array) {
+ my $chan = { CHAN => $cn };
+ if(chanserv::get_user_count($chan)) {
+ bot_join($chan, $nick);
+ }
+ elsif(cr_chk_flag($chan, CRF_BOTSTAY(), 1)) {
+ bot_join($chan, $nick);
+ my $modelock = chanserv::get_modelock($chan);
+ ircd::setmode(main_conf_local, $cn, $modelock) if $modelock;
+ }
+ }
+}
+
+### Database Functions ###
+
+sub set_flag($$) {
+ my ($bot, $flag) = @_;
+
+ $set_flag->execute($flag, $bot);
+}
+
+sub unset_flag($$) {
+ my ($bot, $flag) = @_;
+
+ $unset_flag->execute($flag, $bot);
+}
+
+sub bot_join($;$) {
+ my ($chan, $nick) = @_;
+
+ my $cn = $chan->{CHAN};
+
+ $nick = agent($chan) unless $nick;
+
+ unless(is_agent_in_chan($nick, $cn)) {
+ agent_join($nick, $cn);
+ ircd::setmode($nick, $cn, $botchmode, $nick.(ircd::PREFIXAQ_DISABLE() ? ' '.$nick : '') );
+ }
+}
+
+sub bot_part_if_needed($$$;$) {
+ my ($nick, $chan, $reason, $empty) = @_;
+ my $cn = $chan->{CHAN};
+ my $bot = get_chan_bot($chan);
+ $nick = agent($chan) unless $nick;
+
+ return if (lc $chanserv::enforcers{lc $cn} eq lc $nick);
+
+ if(is_agent_in_chan($nick, $cn)) {
+ if(lc $bot eq lc $nick) {
+ if(cr_chk_flag($chan, CRF_BOTSTAY(), 1) or ($empty != 1 or chanserv::get_user_count($chan))) {
+ return;
+ }
+ }
+
+ agent_part($nick, $cn, $reason);
+ }
+}
+
+sub get_chan_bot($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+ $botserv::get_chan_bot->execute($cn);
+
+ my ($bot) = $botserv::get_chan_bot->fetchrow_array();
+ $botserv::get_chan_bot->finish();
+
+ return $bot;
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package chanserv;
+
+use strict;
+
+use SrSv::Timer qw(add_timer);
+use Data::Dumper;
+use SrSv::Message qw(current_message);
+use SrSv::IRCd::State qw($ircline synced initial_synced %IRCd_capabilities);
+use SrSv::Message qw(message current_message);
+use SrSv::HostMask qw(normalize_hostmask make_hostmask parse_mask);
+#FIXME: This needs to be abstracted into a proper SrSv::IRCd module
+use SrSv::Unreal::Modes qw(@opmodes %opmodes $scm $ocm $acm sanitize_mlockable);
+use SrSv::IRCd::Validate qw( valid_nick validate_chmodes validate_ban );
+use SrSv::Agent;
+
+use SrSv::Shared qw(%enforcers $chanuser_table);
+
+#use SrSv::Conf qw(services);
+use SrSv::Conf2Consts qw( services sql main );
+
+use SrSv::Time;
+use SrSv::Text::Format qw( columnar enum );
+use SrSv::Errors;
+
+use SrSv::Log;
+
+use SrSv::User qw(
+ get_user_nick get_user_agent get_user_id
+ is_online :user_flags get_host get_vhost
+ :flags :flood
+ );
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::ChanReg::Flags;
+
+use SrSv::NickReg::Flags;
+use SrSv::NickReg::NickText;
+use SrSv::NickReg::User qw(is_identified get_nick_users get_nick_user_nicks);
+
+use SrSv::MySQL qw( $dbh :sql_types );
+use SrSv::MySQL::Glob;
+
+use SrSv::Util qw( makeSeqList );
+
+use constant {
+ UOP => 1,
+ VOP => 2,
+ HOP => 3,
+ AOP => 4,
+ SOP => 5,
+ COFOUNDER => 6,
+ FOUNDER => 7,
+
+ # Maybe this should be a config option
+ DEFAULT_BANTYPE => 10,
+
+ CRT_TOPIC => 1,
+ CRT_AKICK => 2,
+};
+
+*get_root_nick = \&nickserv::get_root_nick;
+
+our @levels = ("no", "UOp", "VOp", "HOp", "AOp", "SOp", "co-founder", "founder");
+our @ops;
+if(!ircd::PREFIXAQ_DISABLE()) {
+ @ops = (0, 0, 1, 2, 4, 8, 16, 16); # PREFIX_AQ
+} else { # lame IRC scripts and admins who don't enable PREFIX_AQ
+ @ops = (0, 0, 1, 2, 4, 12, 20, 20); # normal
+}
+our @plevels = ('AKICK', 'anyone', 'UOp', 'VOp', 'HOp', 'AOp', 'SOp', 'co-founder', 'founder', 'disabled');
+our $plzero = 1;
+
+our @override = (
+ ['SERVOP',
+ {
+ ACCCHANGE => 1,
+ SET => 1,
+ MEMO => 1,
+ SETTOPIC => 1,
+ AKICK => 1,
+ LEVELS => 1,
+ COPY => 1,
+ WELCOME => 1,
+ }
+ ],
+ ['SUPER',
+ {
+ BAN => 1,
+ UNBANSELF => 1,
+ UNBAN => 1,
+ KICK => 1,
+ VOICE => 1,
+ HALFOP => 1,
+ OP => 1,
+ ADMIN => 1,
+ OWNER => 1,
+ SETTOPIC => 1,
+ INVITE => 1,
+ INVITESELF => 1,
+ CLEAR => 1,
+ AKICKENFORCE => 1,
+ UPDOWN => 1,
+ MODE => 1,
+ }
+ ],
+ ['HELP',
+ {
+ JOIN => 1,
+ ACCLIST => 1,
+ LEVELSLIST => 1,
+ AKICKLIST => 1,
+ INFO => 1,
+ GETKEY => 1
+ }
+ ],
+ ['BOT',
+ {
+ BOTSAY => 1,
+ BOTASSIGN => 1
+ }
+ ]
+);
+
+$chanuser_table = 0;
+
+our $csnick_default = 'ChanServ';
+our $csnick = $csnick_default;
+
+our ($cur_lock, $cnt_lock);
+
+our (
+ $get_joinpart_lock, $get_modelock_lock, $get_update_modes_lock,
+
+ $chanjoin, $chanpart, $chanpart2, $chop, $chdeop, $get_op, $get_user_chans, $get_user_chans_recent,
+ $get_all_closed_chans, $get_user_count,
+
+ $is_in_chan,
+
+ #$lock_chanuser, $get_all_chan_users,
+ $unlock_tables,
+ $get_chan_users, $get_chan_users_noacc, $get_chan_users_mask, $get_chan_users_mask_noacc,
+
+ $get_users_nochans, $get_users_nochans_noid,
+
+ $get_using_nick_chans,
+
+ $get_lock, $release_lock, $is_free_lock,
+
+ $chan_create, $chan_delete, $get_chanmodes, $set_chanmodes,
+
+ $is_registered, $get_modelock, $set_modelock, $set_descrip,
+
+ $get_topic, $set_topic1, $set_topic2,
+
+ $get_acc, $set_acc1, $set_acc2, $del_acc, $get_acc_list, $get_acc_list2, $get_acc_list_mask, $get_acc_list2_mask,
+ $wipe_acc_list,
+ $get_best_acc, $get_all_acc, $get_highrank, $get_acc_count,
+ $copy_acc, $copy_acc_rank,
+
+ $get_eos_lock, $get_status_all, $get_status_all_server, $get_modelock_all,
+
+ $get_akick, $get_akick_allchan, $get_akick_alluser, $get_akick_all, $add_akick, $del_akick,
+ $get_akick_list, $get_akick_by_num,
+
+ $add_nick_akick, $del_nick_akick, $get_nick_akick, $drop_nick_akick,
+ $copy_akick,
+
+ $is_level, $get_level, $get_levels, $add_level, $set_level, $reset_level, $clear_levels, $get_level_max,
+ $copy_levels,
+
+ $get_founder, $get_successor,
+ $set_founder, $set_successor, $del_successor,
+
+ $get_nick_own_chans, $delete_successors,
+
+ $get_info,
+
+ $register, $drop_acc, $drop_lvl, $drop_akick, $drop,
+ $copy_chanreg,
+
+ $get_expired,
+
+ $get_close, $set_close, $del_close,
+
+ $add_welcome, $del_welcome, $list_welcome, $get_welcomes, $drop_welcome,
+ $count_welcome, $consolidate_welcome,
+
+ $add_ban, $delete_bans, $delete_ban,
+ $get_all_bans, $get_ban_num,
+ $find_bans, $list_bans, $wipe_bans,
+ $find_bans_chan_user, $delete_bans_chan_user,
+
+ $add_auth, $list_auth_chan, $get_auth_nick, $get_auth_num, $find_auth,
+
+ $set_bantype, $get_bantype,
+
+ $drop_chantext, $drop_nicktext,
+ $get_host,
+ $get_host_inchan,
+ $add_tempban,
+ $get_expired_bans,
+ $del_tmpban,
+ $get_bantime,
+ $set_bantime,
+);
+
+sub init() {
+ #$chan_create = $dbh->prepare("INSERT IGNORE INTO chan SET id=(RAND()*294967293)+1, chan=?");
+ $get_joinpart_lock = $dbh->prepare("LOCK TABLES chan WRITE, chanuser WRITE");
+ $get_modelock_lock = $dbh->prepare("LOCK TABLES chanreg READ LOCAL, chan WRITE");
+ $get_update_modes_lock = $dbh->prepare("LOCK TABLES chan WRITE");
+
+ $chanjoin = $dbh->prepare("REPLACE INTO chanuser (seq,nickid,chan,op,joined) VALUES (?, ?, ?, ?, 1)");
+ $chanpart = $dbh->prepare("UPDATE chanuser SET joined=0, seq=?
+ WHERE nickid=? AND chan=? AND (seq <= ? OR seq > ?)");
+ $chanpart2 = $dbh->prepare("UPDATE chanuser SET joined=0 WHERE nickid=? AND chan=?");
+ #$chop = $dbh->prepare("UPDATE chanuser SET op=op+? WHERE nickid=? AND chan=?");
+ $chop = $dbh->prepare("UPDATE chanuser SET op=IF(op & ?, op, op ^ ?) WHERE nickid=? AND chan=?");
+ $chdeop = $dbh->prepare("UPDATE chanuser SET op=IF(op & ?, op ^ ?, op) WHERE nickid=? AND chan=?");
+ $get_op = $dbh->prepare("SELECT op FROM chanuser WHERE nickid=? AND chan=?");
+ $get_user_chans = $dbh->prepare("SELECT chan, op FROM chanuser WHERE nickid=? AND joined=1 AND (seq <= ? OR seq > ?)");
+ $get_user_chans_recent = $dbh->prepare("SELECT chan, joined, op FROM chanuser WHERE nickid=?");
+
+ $get_all_closed_chans = $dbh->prepare("SELECT chanclose.chan, chanclose.type, chanclose.reason, chanclose.nick, chanclose.time FROM chanreg, chanuser, chanclose WHERE chanreg.chan=chanuser.chan AND chanreg.chan=chanclose.chan AND chanreg.flags & ? GROUP BY chanclose.chan ORDER BY NULL");
+ $get_user_count = $dbh->prepare("SELECT COUNT(*) FROM chanuser WHERE chan=? AND joined=1");
+
+ $is_in_chan = $dbh->prepare("SELECT 1 FROM chanuser WHERE nickid=? AND chan=? AND joined=1");
+
+ #$lock_chanuser = $dbh->prepare("LOCK TABLES chanuser READ, user READ");
+ #$get_all_chan_users = $dbh->prepare("SELECT user.nick, chanuser.nickid, chanuser.chan FROM chanuser, user WHERE user.id=chanuser.nickid AND chanuser.joined=1");
+ $unlock_tables = $dbh->prepare("UNLOCK TABLES");
+
+ $get_chan_users = $dbh->prepare("SELECT user.nick, user.id FROM chanuser, user
+ WHERE chanuser.chan=? AND user.id=chanuser.nickid AND chanuser.joined=1");
+ my $chan_users_noacc_tables = 'user '.
+ 'JOIN chanuser ON (chanuser.nickid=user.id AND chanuser.joined=1 AND user.online=1) '.
+ 'LEFT JOIN nickid ON (chanuser.nickid=nickid.id) '.
+ 'LEFT JOIN chanacc ON (nickid.nrid=chanacc.nrid AND chanuser.chan=chanacc.chan)';
+ $get_chan_users_noacc = $dbh->prepare("SELECT user.nick, user.id FROM $chan_users_noacc_tables
+ WHERE chanuser.chan=?
+ GROUP BY user.id HAVING MAX(IF(chanacc.level IS NULL, 0, chanacc.level)) <= 0
+ ORDER BY NULL");
+ my $check_mask = "((user.nick LIKE ?) AND (user.ident LIKE ?)
+ AND ((user.vhost LIKE ?) OR (user.host LIKE ?) OR (user.cloakhost LIKE ?)))";
+ $get_chan_users_mask = $dbh->prepare("SELECT user.nick, user.id FROM chanuser, user
+ WHERE chanuser.chan=? AND user.id=chanuser.nickid AND chanuser.joined=1 AND $check_mask");
+ $get_chan_users_mask_noacc = $dbh->prepare("SELECT user.nick, user.id FROM $chan_users_noacc_tables
+ WHERE chanuser.chan=? AND $check_mask
+ GROUP BY user.id HAVING MAX(IF(chanacc.level IS NULL, 0, chanacc.level)) <= 0
+ ORDER BY NULL");
+
+ $get_users_nochans = $dbh->prepare("SELECT user.nick, user.id
+ FROM user LEFT JOIN chanuser ON (chanuser.nickid=user.id AND chanuser.joined=1)
+ WHERE chanuser.chan IS NULL AND user.online=1");
+ $get_users_nochans_noid = $dbh->prepare("SELECT user.nick, user.id
+ FROM user LEFT JOIN chanuser ON (chanuser.nickid=user.id AND chanuser.joined=1)
+ LEFT JOIN nickid ON (nickid.id=user.id)
+ WHERE chanuser.chan IS NULL AND nickid.id IS NULL
+ AND user.online=1");
+
+ $get_using_nick_chans = $dbh->prepare("SELECT user.nick FROM user, nickid, nickreg, chanuser
+ WHERE user.id=nickid.id AND user.id=chanuser.nickid AND nickid.nrid=nickreg.id AND chanuser.joined=1
+ AND nickreg.nick=? AND chanuser.chan=?");
+
+ $get_lock = $dbh->prepare("SELECT GET_LOCK(?, 3)");
+ $release_lock = $dbh->prepare("DO RELEASE_LOCK(?)");
+ $is_free_lock = $dbh->prepare("SELECT IS_FREE_LOCK(?)");
+
+ $chan_create = $dbh->prepare("INSERT IGNORE INTO chan SET seq=?, chan=?");
+ $chan_delete = $dbh->prepare("DELETE FROM chan WHERE chan=?");
+ $get_chanmodes = $dbh->prepare("SELECT modes FROM chan WHERE chan=?");
+ $set_chanmodes = $dbh->prepare("REPLACE INTO chan SET modes=?, chan=?");
+
+ $is_registered = $dbh->prepare("SELECT 1 FROM chanreg WHERE chan=?");
+ $get_modelock = $dbh->prepare("SELECT modelock FROM chanreg WHERE chan=?");
+ $set_modelock = $dbh->prepare("UPDATE chanreg SET modelock=? WHERE chan=?");
+
+ $set_descrip = $dbh->prepare("UPDATE chanreg SET descrip=? WHERE chan=?");
+
+ $get_topic = $dbh->prepare("SELECT chantext.data, topicer, topicd FROM chanreg, chantext
+ WHERE chanreg.chan=chantext.chan AND chantext.chan=?");
+ $set_topic1 = $dbh->prepare("UPDATE chanreg SET chanreg.topicer=?, chanreg.topicd=?
+ WHERE chanreg.chan=?");
+ $set_topic2 = $dbh->prepare("REPLACE INTO chantext SET chan=?, type=".CRT_TOPIC().", data=?");
+
+ $get_acc = $dbh->prepare("SELECT chanacc.level FROM chanacc, nickalias
+ WHERE chanacc.chan=? AND chanacc.nrid=nickalias.nrid AND nickalias.alias=?");
+ $set_acc1 = $dbh->prepare("INSERT IGNORE INTO chanacc SELECT ?, nrid, ?, NULL, UNIX_TIMESTAMP(), 0
+ FROM nickalias WHERE alias=?");
+ $set_acc2 = $dbh->prepare("UPDATE chanacc, nickalias
+ SET chanacc.level=?, chanacc.adder=?, chanacc.time=UNIX_TIMESTAMP()
+ WHERE chanacc.chan=? AND chanacc.nrid=nickalias.nrid AND nickalias.alias=?");
+ $del_acc = $dbh->prepare("DELETE FROM chanacc USING chanacc, nickalias
+ WHERE chanacc.chan=? AND chanacc.nrid=nickalias.nrid AND nickalias.alias=?");
+ $wipe_acc_list = $dbh->prepare("DELETE FROM chanacc WHERE chan=? AND level=?");
+ $get_acc_list = $dbh->prepare("SELECT nickreg.nick, chanacc.adder, chanacc.time,
+ chanacc.last, nickreg.ident, nickreg.vhost
+ FROM chanacc, nickreg
+ WHERE chanacc.chan=? AND chanacc.level=? AND chanacc.nrid=nickreg.id AND chanacc.level > 0 ORDER BY nickreg.nick");
+ $get_acc_list2 = $dbh->prepare("SELECT nickreg.nick, chanacc.adder, chanacc.level, chanacc.time,
+ chanacc.last, nickreg.ident, nickreg.vhost
+ FROM chanacc, nickreg
+ WHERE chanacc.chan=? AND chanacc.nrid=nickreg.id AND chanacc.level > 0 ORDER BY nickreg.nick");
+ $get_acc_list_mask = $dbh->prepare("SELECT IF (nickreg.nick LIKE ?, nickreg.nick, nickalias.alias), chanacc.adder, chanacc.time,
+ chanacc.last, nickreg.ident, nickreg.vhost, COUNT(nickreg.id) as c
+ FROM chanacc, nickalias, nickreg
+ WHERE chanacc.chan=? AND chanacc.level=? AND chanacc.nrid=nickalias.nrid AND nickreg.id=nickalias.nrid
+ AND chanacc.level > 0
+ AND nickalias.alias LIKE ? AND nickreg.ident LIKE ? AND nickreg.vhost LIKE ?
+ GROUP BY nickreg.id
+ ORDER BY nickalias.alias");
+ $get_acc_list2_mask = $dbh->prepare("SELECT IF (nickreg.nick LIKE ?, nickreg.nick, nickalias.alias),
+ chanacc.adder, chanacc.level, chanacc.time,
+ chanacc.last, nickreg.ident, nickreg.vhost, COUNT(nickreg.id) as c
+ FROM chanacc, nickalias, nickreg
+ WHERE chanacc.chan=? AND chanacc.nrid=nickalias.nrid AND nickreg.id=nickalias.nrid
+ AND chanacc.level > 0
+ AND nickalias.alias LIKE ? AND nickreg.ident LIKE ? AND nickreg.vhost LIKE ?
+ GROUP BY nickreg.id
+ ORDER BY nickalias.alias");
+
+ $get_best_acc = $dbh->prepare("SELECT nickreg.nick, chanacc.level
+ FROM nickid, nickalias, nickreg, chanacc
+ WHERE nickid.nrid=nickreg.id AND nickalias.nrid=nickreg.id AND nickid.id=?
+ AND chanacc.nrid=nickreg.id AND chanacc.chan=? ORDER BY chanacc.level DESC LIMIT 1");
+ $get_all_acc = $dbh->prepare("SELECT nickreg.nick, chanacc.level
+ FROM nickid, nickreg, chanacc
+ WHERE nickid.nrid=nickreg.id AND nickid.id=? AND chanacc.nrid=nickreg.id
+ AND chanacc.chan=? ORDER BY chanacc.level");
+ $get_highrank = $dbh->prepare("SELECT user.nick, chanacc.level FROM chanuser, nickid, chanacc, user WHERE chanuser.chan=? AND chanuser.joined=1 AND chanuser.chan=chanacc.chan AND chanuser.nickid=nickid.id AND user.id=nickid.id AND nickid.nrid=chanacc.nrid ORDER BY chanacc.level DESC LIMIT 1");
+ $get_acc_count = $dbh->prepare("SELECT COUNT(*) FROM chanacc WHERE chan=? AND level=?");
+ $copy_acc = $dbh->prepare("REPLACE INTO chanacc
+ ( chan, nrid, level, adder, time)
+ SELECT ?, nrid, level, adder, time FROM chanacc JOIN nickreg ON (chanacc.nrid=nickreg.id)
+ WHERE chan=? AND nickreg.nick!=? AND chanacc.level!=7");
+ $copy_acc_rank = $dbh->prepare("REPLACE INTO chanacc
+ ( chan, nrid, level, adder, time)
+ SELECT ?, nrid, level, adder, time FROM chanacc
+ WHERE chan=? AND chanacc.level=?");
+
+ $get_eos_lock = $dbh->prepare("LOCK TABLES akick READ LOCAL, welcome READ LOCAL, chanuser WRITE, user WRITE,
+ user AS u1 READ, user AS u2 READ, chan WRITE, chanreg WRITE, nickid READ LOCAL, nickreg READ LOCAL,
+ nickalias READ LOCAL, chanacc READ LOCAL, chanban WRITE, svsop READ");
+ my $get_status_all_1 = "SELECT chanuser.chan, chanreg.flags, chanreg.bot, user.nick, user.id, user.flags, MAX(chanacc.level), chanuser.op, MAX(nickreg.flags & ".NRF_NEVEROP().")
+ FROM user, chanreg, chanuser
+ LEFT JOIN nickid ON(nickid.id=chanuser.nickid)
+ LEFT JOIN nickreg ON(nickid.nrid=nickreg.id)
+ LEFT JOIN chanacc ON(chanacc.chan=chanuser.chan AND chanacc.nrid=nickid.nrid AND (nickreg.flags & ".NRF_NEVEROP().")=0)
+ WHERE";
+ my $get_status_all_2 = "(user.flags & ".UF_FINISHED().")=0 AND chanuser.joined=1 AND (chanreg.flags & ".(CRF_CLOSE|CRF_DRONE).") = 0 AND chanreg.chan=chanuser.chan AND user.id=chanuser.nickid AND (nickid.nrid IS NULL OR nickreg.id IS NOT NULL)
+ GROUP BY chanuser.chan, chanuser.nickid ORDER BY NULL";
+ $get_status_all = $dbh->prepare("$get_status_all_1 $get_status_all_2");
+ $get_status_all_server = $dbh->prepare("$get_status_all_1 user.server=? AND $get_status_all_2");
+
+ $get_modelock_all = $dbh->prepare("SELECT chanuser.chan, chan.modes, chanreg.modelock FROM chanreg, chan, chanuser WHERE chanuser.joined=1 AND chanreg.chan=chan.chan AND chanreg.chan=chanuser.chan GROUP BY chanreg.chan ORDER BY NULL");
+
+ my $akick_rows = "user.nick, akick.nick, akick.ident, akick.host, akick.reason";
+ my $akick_no_zerolen = "(akick.ident != '' AND akick.host != '')";
+ my $akick_single_cond = "$akick_no_zerolen AND user.nick LIKE akick.nick AND user.ident LIKE akick.ident ".
+ "AND ( (user.host LIKE akick.host) OR (user.vhost LIKE akick.host) OR ".
+ "(IF((user.ip IS NOT NULL) AND (user.ip != 0), INET_NTOA(user.ip) LIKE akick.host, 0)) OR ".
+ "(IF(user.cloakhost IS NOT NULL, user.cloakhost LIKE akick.host, 0)) )";
+ my $akick_multi_cond = "chanuser.chan=akick.chan AND $akick_single_cond";
+
+ $get_akick = $dbh->prepare("SELECT $akick_rows FROM akick, user ".
+ "WHERE user.id=? AND akick.chan=? AND $akick_single_cond LIMIT 1");
+ $get_akick_allchan = $dbh->prepare("SELECT $akick_rows FROM $chan_users_noacc_tables
+ JOIN akick ON($akick_multi_cond)
+ WHERE akick.chan=?
+ GROUP BY user.id HAVING MAX(IF(chanacc.level IS NULL, 0, chanacc.level)) <= 0
+ ORDER BY NULL");
+ $get_akick_alluser = $dbh->prepare("SELECT akick.chan, $akick_rows FROM $chan_users_noacc_tables
+ JOIN akick ON($akick_multi_cond)
+ WHERE chanuser.nickid=?
+ GROUP BY user.id HAVING MAX(IF(chanacc.level IS NULL, 0, chanacc.level)) <= 0
+ ORDER BY NULL");
+ $get_akick_all = $dbh->prepare("SELECT akick.chan, $akick_rows FROM $chan_users_noacc_tables
+ JOIN akick ON($akick_multi_cond)
+ GROUP BY akick.chan, user.id HAVING MAX(IF(chanacc.level IS NULL, 0, chanacc.level)) <= 0
+ ORDER BY NULL");
+
+ $add_akick = $dbh->prepare("INSERT INTO akick SET chan=?, nick=?, ident=?, host=?, adder=?, reason=?, time=UNIX_TIMESTAMP()");
+ $add_akick->{PrintError} = 0;
+ $del_akick = $dbh->prepare("DELETE FROM akick WHERE chan=? AND nick=? AND ident=? AND host=?");
+ $get_akick_list = $dbh->prepare("SELECT nick, ident, host, adder, reason, time FROM akick WHERE chan=? ORDER BY time");
+
+ $add_nick_akick = $dbh->prepare("INSERT INTO akick SELECT ?, nickalias.nrid, '', '', ?, ?, UNIX_TIMESTAMP()
+ FROM nickalias WHERE alias=?");
+ $del_nick_akick = $dbh->prepare("DELETE FROM akick USING akick, nickalias
+ WHERE akick.chan=? AND akick.nick=nickalias.nrid AND akick.ident='' AND akick.host='' AND nickalias.alias=?");
+ $get_nick_akick = $dbh->prepare("SELECT reason FROM akick, nickalias
+ WHERE akick.chan=? AND akick.nick=nickalias.nrid AND akick.ident='' AND akick.host='' AND nickalias.alias=?");
+ $drop_nick_akick = $dbh->prepare("DELETE FROM akick USING akick, nickreg
+ WHERE akick.nick=nickreg.id AND akick.ident='' AND akick.host='' AND nickreg.nick=?");
+ $copy_akick = $dbh->prepare("REPLACE INTO akick
+ ( chan, nick, ident, host, adder, reason, time)
+ SELECT ?, nick, ident, host, adder, reason, time FROM akick WHERE chan=?");
+ $get_akick_by_num = $dbh->prepare("SELECT akick.nick, akick.ident, akick.host FROM akick WHERE chan=?
+ ORDER BY time LIMIT 1 OFFSET ?");
+ $get_akick_by_num->bind_param(2, 0, SQL_INTEGER);
+
+ $is_level = $dbh->prepare("SELECT 1 FROM chanperm WHERE chanperm.name=?");
+ $get_level = $dbh->prepare("SELECT IF(chanlvl.level IS NULL, chanperm.level, chanlvl.level), chanlvl.level
+ FROM chanperm LEFT JOIN chanlvl ON chanlvl.perm=chanperm.id AND chanlvl.chan=?
+ WHERE chanperm.name=?");
+ $get_levels = $dbh->prepare("SELECT chanperm.name, chanperm.level, chanlvl.level FROM chanperm LEFT JOIN chanlvl ON chanlvl.perm=chanperm.id AND chanlvl.chan=? ORDER BY chanperm.name");
+ $add_level = $dbh->prepare("INSERT IGNORE INTO chanlvl SELECT ?, chanperm.id, chanperm.level FROM chanperm WHERE chanperm.name=?");
+ $set_level = $dbh->prepare("UPDATE chanlvl, chanperm SET chanlvl.level=? WHERE chanlvl.chan=? AND chanperm.id=chanlvl.perm AND chanperm.name=?");
+ $reset_level = $dbh->prepare("DELETE FROM chanlvl USING chanlvl, chanperm WHERE chanperm.name=? AND chanlvl.perm=chanperm.id AND chanlvl.chan=?");
+ $clear_levels = $dbh->prepare("DELETE FROM chanlvl WHERE chan=?");
+ $get_level_max = $dbh->prepare("SELECT max FROM chanperm WHERE name=?");
+ $copy_levels = $dbh->prepare("REPLACE INTO chanlvl
+ ( chan, perm, level)
+ SELECT ?, perm, level FROM chanlvl WHERE chan=?");
+
+ $get_founder = $dbh->prepare("SELECT nickreg.nick FROM chanreg, nickreg WHERE chanreg.chan=? AND chanreg.founderid=nickreg.id");
+ $get_successor = $dbh->prepare("SELECT nickreg.nick FROM chanreg, nickreg WHERE chanreg.chan=? AND chanreg.successorid=nickreg.id");
+ $set_founder = $dbh->prepare("UPDATE chanreg, nickreg SET chanreg.founderid=nickreg.id WHERE nickreg.nick=? AND chanreg.chan=?");
+ $set_successor = $dbh->prepare("UPDATE chanreg, nickreg SET chanreg.successorid=nickreg.id WHERE nickreg.nick=? AND chanreg.chan=?");
+ $del_successor = $dbh->prepare("UPDATE chanreg SET chanreg.successorid=NULL WHERE chanreg.chan=?");
+
+ $get_nick_own_chans = $dbh->prepare("SELECT chanreg.chan FROM chanreg, nickreg WHERE nickreg.nick=? AND chanreg.founderid=nickreg.id");
+ $delete_successors = $dbh->prepare("UPDATE chanreg, nickreg SET chanreg.successorid=NULL WHERE nickreg.nick=? AND chanreg.successorid=nickreg.id");
+
+
+ $get_info = $dbh->prepare("SELECT chanreg.descrip, chanreg.regd, chanreg.last, chantext.data,
+ chanreg.topicer, chanreg.modelock, foundernick.nick, successornick.nick, chanreg.bot, chanreg.bantype, chanreg.bantime
+ FROM nickreg AS foundernick, chanreg
+ LEFT JOIN nickreg AS successornick ON(successornick.id=chanreg.successorid)
+ LEFT JOIN chantext ON (chanreg.chan=chantext.chan AND chantext.type=".CRT_TOPIC().")
+ WHERE chanreg.chan=? AND foundernick.id=chanreg.founderid");
+
+ $register = $dbh->prepare("INSERT INTO chanreg
+ SELECT ?, ?, UNIX_TIMESTAMP(), UNIX_TIMESTAMP(), NULL, NULL,
+ NULL, id, NULL, NULL, NULL, ".DEFAULT_BANTYPE().",0 FROM nickreg WHERE nick=?");
+ $register->{PrintError} = 0;
+ $copy_chanreg = $dbh->prepare("INSERT INTO chanreg
+ ( chan, descrip, regd, last, modelock, founderid, successorid, bot, flags, bantype,bantime)
+ SELECT ?, descrip, UNIX_TIMESTAMP(), UNIX_TIMESTAMP(), modelock, founderid, successorid, bot, flags, bantype,bantime
+ FROM chanreg WHERE chan=?");
+ $get_bantime = $dbh->prepare ("SELECT bantime FROM chanreg WHERE chan=?");
+ $set_bantime = $dbh->prepare ("UPDATE chanreg SET bantime=? WHERE chan=?");
+ $drop_acc = $dbh->prepare("DELETE FROM chanacc WHERE chan=?");
+ $drop_lvl = $dbh->prepare("DELETE FROM chanlvl WHERE chan=?");
+ $drop_akick = $dbh->prepare("DELETE FROM akick WHERE chan=?");
+ $drop = $dbh->prepare("DELETE FROM chanreg WHERE chan=?");
+
+ $get_expired = $dbh->prepare("SELECT chanreg.chan, nickreg.nick FROM nickreg, chanreg
+ LEFT JOIN chanuser ON(chanreg.chan=chanuser.chan AND chanuser.op!=0)
+ WHERE chanreg.founderid=nickreg.id AND chanuser.chan IS NULL AND chanreg.last<? AND
+ !(chanreg.flags & " . CRF_HOLD . ")");
+
+ $get_close = $dbh->prepare("SELECT reason, nick, time FROM chanclose WHERE chan=?");
+ $set_close = $dbh->prepare("REPLACE INTO chanclose SET chan=?, reason=?, nick=?, time=UNIX_TIMESTAMP(), type=?");
+ $del_close = $dbh->prepare("DELETE FROM chanclose WHERE chan=?");
+
+ $add_welcome = $dbh->prepare("REPLACE INTO welcome SET chan=?, id=?, adder=?, time=UNIX_TIMESTAMP(), msg=?");
+ $del_welcome = $dbh->prepare("DELETE FROM welcome WHERE chan=? AND id=?");
+ $list_welcome = $dbh->prepare("SELECT id, time, adder, msg FROM welcome WHERE chan=? ORDER BY id");
+ $get_welcomes = $dbh->prepare("SELECT msg FROM welcome WHERE chan=? ORDER BY id");
+ $drop_welcome = $dbh->prepare("DELETE FROM welcome WHERE chan=?");
+ $count_welcome = $dbh->prepare("SELECT COUNT(*) FROM welcome WHERE chan=?");
+ $consolidate_welcome = $dbh->prepare("UPDATE welcome SET id=id-1 WHERE chan=? AND id>?");
+ $add_tempban = $dbh->prepare ("INSERT INTO tmpban values (?,?,UNIX_TIMESTAMP()+?,UNIX_TIMESTAMP())");
+ $add_ban = $dbh->prepare("INSERT IGNORE INTO chanban SET chan=?, mask=?, setter=?, type=?, time=UNIX_TIMESTAMP()");
+ $delete_bans = $dbh->prepare("DELETE FROM chanban WHERE chan=? AND ? LIKE mask AND type=?");
+ # likely need a better name for this or for the above.
+ $delete_ban = $dbh->prepare("DELETE FROM chanban WHERE chan=? AND mask=? AND type=?");
+ $find_bans = $dbh->prepare("SELECT mask FROM chanban WHERE chan=? AND ? LIKE mask AND type=?");
+ $get_all_bans = $dbh->prepare("SELECT mask FROM chanban WHERE chan=? AND type=?");
+ $get_ban_num = $dbh->prepare("SELECT mask FROM chanban WHERE chan=? AND type=? ORDER BY time, mask LIMIT 1 OFFSET ?");
+ $get_ban_num->bind_param(3, 0, SQL_INTEGER);
+ $list_bans = $dbh->prepare("SELECT mask, setter, time FROM chanban WHERE chan=? AND type=? ORDER BY time, mask");
+ $wipe_bans = $dbh->prepare("DELETE FROM chanban WHERE chan=?");
+
+ my $chanban_mask = "((CONCAT(user.nick, '!', user.ident, '\@', user.host) LIKE chanban.mask) ".
+ "OR (CONCAT(user.nick , '!' , user.ident , '\@' , user.vhost) LIKE chanban.mask) ".
+ "OR IF(user.cloakhost IS NOT NULL, ".
+ "(CONCAT(user.nick , '!' , user.ident , '\@' , user.cloakhost) LIKE chanban.mask), 0))";
+ $find_bans_chan_user = $dbh->prepare("SELECT mask FROM chanban,user
+ WHERE chan=? AND user.id=? AND type=? AND $chanban_mask");
+ $delete_bans_chan_user = $dbh->prepare("DELETE FROM chanban USING chanban,user
+ WHERE chan=? AND user.id=? AND type=? AND $chanban_mask");
+
+ $add_auth = $dbh->prepare("REPLACE INTO nicktext
+ SELECT nickalias.nrid, (".NTF_AUTH()."), 1, ?, ? FROM nickalias WHERE nickalias.alias=?");
+ $list_auth_chan = $dbh->prepare("SELECT nickreg.nick, nicktext.data FROM nickreg, nicktext
+ WHERE nickreg.id=nicktext.nrid AND nicktext.type=(".NTF_AUTH().") AND nicktext.chan=?");
+ $get_auth_nick = $dbh->prepare("SELECT nicktext.data FROM nickreg, nickalias, nicktext
+ WHERE nickreg.id=nicktext.nrid AND nickreg.id=nickalias.nrid AND nicktext.type=(".NTF_AUTH().")
+ AND nicktext.chan=? AND nickalias.alias=?");
+ $get_auth_num = $dbh->prepare("SELECT nickreg.nick, nicktext.data FROM nickreg, nickalias, nicktext
+ WHERE nickreg.id=nicktext.nrid AND nickreg.id=nickalias.nrid AND nicktext.type=(".NTF_AUTH().")
+ AND nicktext.chan=? LIMIT 1 OFFSET ?");
+ $get_auth_num->bind_param(2, 0, SQL_INTEGER);
+ $find_auth = $dbh->prepare("SELECT 1 FROM nickalias, nicktext
+ WHERE nickalias.nrid=nicktext.nrid AND nicktext.type=(".NTF_AUTH().")
+ AND nicktext.chan=? AND nickalias.alias=?");
+
+ $set_bantype = $dbh->prepare("UPDATE chanreg SET bantype=? WHERE chan=?");
+ $get_bantype = $dbh->prepare("SELECT bantype FROM chanreg WHERE chan=?");
+
+ $drop_chantext = $dbh->prepare("DELETE FROM chantext WHERE chan=?");
+ $drop_nicktext = $dbh->prepare("DELETE nicktext.* FROM nicktext WHERE nicktext.chan=?");
+ $get_host = $dbh->prepare ("SELECT user.host from user where user.nick=?");
+ $get_host_inchan= $dbh->prepare ("SELECT clonedUsers.nick FROM user AS curUser JOIN user AS clonedUsers ON (curUser.host=clonedUsers.host) JOIN chanuser ON (chanuser.nickid=clonedUsers.id) WHERE clonedUsers.id!=curUser.id AND curUser.id=? AND chanuser.chan=? AND chanuser.joined=1");
+ $get_expired_bans = $dbh->prepare("SELECT channel, banmask, expiry, timeset FROM tmpban WHERE expiry < UNIX_TIMESTAMP()");
+ $del_tmpban = $dbh->prepare("DELETE FROM tmpban WHERE channel=? AND banmask = ?");
+}
+
+use SrSv::MySQL::Stub {
+ set_lastop => ['NULL', "UPDATE chanreg SET last=UNIX_TIMESTAMP() WHERE chan=?"],
+ set_lastused => ['NULL', "UPDATE chanacc, nickid SET chanacc.last=UNIX_TIMESTAMP() WHERE
+ chanacc.chan=? AND nickid.id=? AND chanacc.nrid=nickid.nrid AND chanacc.level > 0"],
+ get_recent_private_chans => ['COLUMN', "SELECT DISTINCT chanuser.chan FROM chanuser
+ JOIN chanacc ON (chanuser.chan=chanacc.chan AND chanuser.joined=0)
+ JOIN chanlvl ON (chanlvl.level <= chanacc.level AND chanlvl.level > 0 AND chanuser.chan=chanlvl.chan)
+ JOIN chanperm ON (chanlvl.perm=chanperm.id)
+ JOIN nickid ON (chanuser.nickid=nickid.id AND chanacc.nrid=nickid.nrid)
+ WHERE chanperm.name='Join'
+ AND nickid.id=?"],
+};
+
+### CHANSERV COMMANDS ###
+
+our %high_priority_cmds = (
+ kick => 1,
+ mode => 1,
+ kb => 1,
+ kickban => 1,
+ kickb => 1,
+ kban => 1,
+ down => 1,
+);
+sub check_expired_bans() {
+ add_timer('ChanServ Expire', 10, __PACKAGE__, 'chanserv::check_expired_bans');
+ $get_expired_bans->execute();
+
+ while (my ($cn, $ban) = $get_expired_bans->fetchrow_array()) {
+ my $chan = {CHAN=>$cn};
+ ircd::setmode(agent($chan), $cn, '-b', $ban);
+ ircd::flushmodes();
+ }
+}
+sub tempban($$;$) {
+ my ($chan, $bansref, $expiresref) = @_;
+
+ my $cn = $chan->{CHAN};
+ my @bans = @$bansref;
+ my @expires = @$expiresref;
+
+ foreach my $ban (@bans) {
+ my $expiry = shift @expires;
+ $add_tempban->execute($cn, $ban, $expiry);
+ }
+
+ ircd::ban_list(agent($chan), $cn, +1, 'b', @bans) if (scalar(@bans));
+}
+sub clones_exist ($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ unless(cr_chk_flag($chan, CRF_NOCLONES)) {
+ return;
+ }
+
+ my $nick = $user->{NICK};
+ $get_host_inchan->execute(get_user_id($user), $cn);
+ my ($joined) = $get_host_inchan->fetchrow_array;
+ $get_host_inchan->finish();
+
+ if ($joined) {
+ return $joined;
+ }
+
+ return 0;
+}
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT => $dst };
+
+ return if flood_check($user);
+
+ if(!defined($high_priority_cmds{lc $cmd}) &&
+ !adminserv::is_svsop($user) &&
+ $SrSv::IRCd::State::queue_depth > main_conf_highqueue)
+ {
+ notice($user, get_user_agent($user)." is too busy right now. Please try your command again later.");
+ return;
+ }
+
+ if($cmd =~ /^register$/i) {
+ if(@args >= 1) {
+ my @args = split(/\s+/, $msg, 4);
+ cs_register($user, { CHAN => $args[1] }, $args[2], $args[3]);
+ } else {
+ notice($user, 'Syntax: REGISTER <#channel> [password] [description]');
+ }
+ }
+ elsif ($cmd =~ /^t((e)?mp)?b(an)?$/i) {
+ my @args = split (/\s+/, $msg, 2);
+
+ my (undef, $args) = @args;
+ cs_tempban ($user, $args);
+ }
+
+
+ elsif($cmd =~ /^(?:[uvhas]op|co?f(ounder)?)$/i) {
+ my ($cn, $cmd2) = splice(@args, 0, 2);
+ my $chan = { CHAN => $cn };
+
+ if($cmd2 =~ /^add$/i) {
+ if(@args == 1) {
+ cs_xop_add($user, $chan, $cmd, $args[0]);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> ADD <nick>');
+ }
+ }
+ elsif($cmd2 =~ /^del(ete)?$/i) {
+ if(@args == 1) {
+ cs_xop_del($user, $chan, $cmd, $args[0]);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> DEL <nick>');
+ }
+ }
+ elsif($cmd2 =~ /^list$/i) {
+ if(@args >= 0) {
+ cs_xop_list($user, $chan, $cmd, $args[0]);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> LIST [mask]');
+ }
+ }
+ elsif($cmd2 =~ /^(wipe|clear)$/i) {
+ if(@args == 0) {
+ cs_xop_wipe($user, $chan, $cmd);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> WIPE');
+ }
+ }
+ else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> <ADD|DEL|LIST|WIPE>');
+ }
+ }
+ elsif($cmd =~ /^levels$/i) {
+ if(@args < 2) {
+ notice($user, 'Syntax: LEVELS <#channel> <SET|RESET|LIST|CLEAR>');
+ return;
+ }
+
+ my $cmd2 = lc(splice(@args, 1, 1));
+
+ if($cmd2 eq 'set') {
+ if(@args == 3) {
+ cs_levels_set($user, { CHAN => $args[0] }, $args[1], $args[2]);
+ } else {
+ notice($user, 'Syntax: LEVELS <#channel> SET <permission> <level>');
+ }
+ }
+ elsif($cmd2 eq 'reset') {
+ if(@args == 2) {
+ cs_levels_set($user, { CHAN => $args[0] }, $args[1]);
+ } else {
+ notice($user, 'Syntax: LEVELS <#channel> RESET <permission>');
+ }
+ }
+ elsif($cmd2 eq 'list') {
+ if(@args == 1) {
+ cs_levels_list($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: LEVELS <#channel> LIST');
+ }
+ }
+ elsif($cmd2 eq 'clear') {
+ if(@args == 1) {
+ cs_levels_clear($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: LEVELS <#channel> CLEAR');
+ }
+ }
+ else {
+ notice($user, 'Syntax: LEVELS <#channel> <SET|RESET|LIST|CLEAR>');
+ }
+ }
+ elsif($cmd =~ /^akick$/i) {
+ if(@args < 2) {
+ notice($user, 'Syntax: AKICK <#channel> <ADD|DEL|LIST|WIPE|CLEAR>');
+ return;
+ }
+
+ #my $cmd2 = lc($args[1]);
+ my $cmd2 = lc(splice(@args, 1, 1));
+
+ if($cmd2 eq 'add') {
+ if(@args >= 2) {
+ my @args = split(/\s+/, $msg, 5);
+ cs_akick_add($user, { CHAN => $args[1] }, $args[3], $args[4]);
+ } else {
+ notice($user, 'Syntax: AKICK <#channel> ADD <nick|mask> <reason>');
+ }
+ }
+ elsif($cmd2 eq 'del') {
+ if(@args >= 2) {
+ cs_akick_del($user, { CHAN => $args[0] }, $args[1]);
+ } else {
+ notice($user, 'Syntax: AKICK <#channel> DEL <nick|mask|num|seq>');
+ }
+ }
+ elsif($cmd2 eq 'list') {
+ if(@args == 1) {
+ cs_akick_list($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: AKICK <#channel> LIST');
+ }
+ }
+ elsif($cmd2 =~ /^(wipe|clear)$/i) {
+ if(@args == 1) {
+ cs_akick_wipe($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: AKICK <#channel> WIPE');
+ }
+ }
+ elsif($cmd2 =~ /^enforce$/i) {
+ if(@args == 1) {
+ cs_akick_enforce($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: AKICK <#channel> ENFORCE');
+ }
+ }
+ else {
+ notice($user, 'Syntax: AKICK <#channel> <ADD|DEL|LIST|WIPE|CLEAR>');
+ }
+ }
+ elsif($cmd =~ /^info$/i) {
+ if(@args == 1) {
+ cs_info($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: INFO <channel>');
+ }
+ }
+ elsif($cmd =~ /^set$/i) {
+ if(@args == 2 and lc($args[1]) eq 'unsuccessor') {
+ cs_set($user, { CHAN => $args[0] }, $args[1]);
+ }
+ elsif(@args >= 3 and (
+ $args[1] =~ /m(?:ode)?lock/i or
+ lc($args[1]) eq 'desc'
+ )) {
+ my @args = split(/\s+/, $msg, 4);
+ cs_set($user, { CHAN => $args[1] }, $args[2], $args[3]);
+ }
+ elsif(@args == 3) {
+ cs_set($user, { CHAN => $args[0] }, $args[1], $args[2]);
+ }
+ else {
+ notice($user, 'Syntax: SET <channel> <option> <value>');
+ }
+ }
+ elsif($cmd =~ /^why$/i) {
+ if(@args == 1) {
+ cs_why($user, { CHAN => shift @args }, $src);
+ }
+ elsif(@args >= 2) {
+ cs_why($user, { CHAN => shift @args }, @args);
+ } else {
+ notice($user, 'Syntax: WHY <channel> <nick> [nick [nick ...]]');
+ return;
+ }
+ }
+ elsif($cmd =~ /^(de)?(voice|h(alf)?op|op|protect|admin|owner)$/i) {
+ if(@args >= 1) {
+ cs_setmodes($user, $cmd, { CHAN => shift(@args) }, @args);
+ } else {
+ notice($user, 'Syntax: '.uc($cmd).' <channel> [nick [nick ...]]');
+ }
+ }
+ elsif($cmd =~ /^(up|down)$/i) {
+ cs_updown($user, $cmd, @args);
+ }
+ elsif($cmd =~ /^drop$/i) {
+ if(@args == 1) {
+ cs_drop($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: DROP <channel>');
+ }
+ }
+ elsif($cmd =~ /^help$/i) {
+ sendhelp($user, 'chanserv', @args)
+ }
+ elsif($cmd =~ /^count$/i) {
+ if(@args == 1) {
+ cs_count($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: COUNT <channel>');
+ }
+ }
+ elsif($cmd =~ /^k(?:ick)?$/i) {
+ my @args = split(/\s+/, $msg, 4); shift @args;
+ if(@args >= 2) {
+ cs_kick($user, { CHAN => $args[0] }, $args[1], 0, $args[2])
+ }
+ else {
+ notice($user, 'Syntax: KICK <channel> <nick> [reason]');
+ }
+ }
+ elsif($cmd =~ /^(k(ick)?b(an)?|b(an)?k(ick)?)$/i) {
+ my @args = split(/\s+/, $msg, 4); shift @args;
+ if(@args >= 2) {
+ cs_kick($user, { CHAN => $args[0] }, $args[1], 1, $args[2]);
+ } else {
+ notice($user, 'Syntax: KICKBAN <channel> <nick> [reason]');
+ }
+ }
+ elsif($cmd =~ /^k(ick)?m(ask)?$/i) {
+ my @args = split(/\s+/, $msg, 4); shift @args;
+ if(@args >= 2) {
+ cs_kickmask($user, { CHAN => $args[0] }, $args[1], 0, $args[2])
+ }
+ else {
+ notice($user, 'Syntax: KICKMASK <channel> <mask> [reason]');
+ }
+ }
+ elsif($cmd =~ /^(k(ick)?b(an)?|b(an)?k(ick)?)m(ask)?$/i) {
+ my @args = split(/\s+/, $msg, 4); shift @args;
+ if(@args >= 2) {
+ cs_kickmask($user, { CHAN => $args[0] }, $args[1], 1, $args[2]);
+ } else {
+ notice($user, 'Syntax: KICKBANMASK <channel> <mask> [reason]');
+ }
+ }
+ elsif($cmd =~ /^invite$/i) {
+ my $chan = shift @args;
+ if(@args == 0) {
+ cs_invite($user, { CHAN => $chan }, $src)
+ }
+ elsif(@args >= 1) {
+ cs_invite($user, { CHAN => $chan }, @args)
+ }
+ else {
+ notice($user, 'Syntax: INVITE <channel> <nick>');
+ }
+ }
+ elsif($cmd =~ /^(close|forbid)$/i) {
+ if(@args > 1) {
+ my @args = split(/\s+/, $msg, 3);
+ cs_close($user, { CHAN => $args[1] }, $args[2], CRF_CLOSE);
+ }
+ else {
+ notice($user, 'Syntax: CLOSE <chan> <reason>');
+ }
+ }
+ elsif($cmd =~ /^drone$/i) {
+ if(@args > 1) {
+ my @args = split(/\s+/, $msg, 3);
+ cs_close($user, { CHAN => $args[1] }, $args[2], CRF_DRONE);
+ }
+ else {
+ notice($user, 'Syntax: DRONE <chan> <reason>');
+ }
+ }
+ elsif($cmd =~ /^clear$/i) {
+ my ($cmd, $chan, $clearcmd, $reason) = split(/\s+/, $msg, 4);
+ unless ($chan and $clearcmd) {
+ notice($user, 'Syntax: CLEAR <channel> <MODES|OPS|USERS|BANS> [reason]');
+ return;
+ }
+ if($clearcmd =~ /^modes$/i) {
+ cs_clear_modes($user, { CHAN => $chan }, $reason);
+ }
+ elsif($clearcmd =~ /^ops$/i) {
+ cs_clear_ops($user, { CHAN => $chan }, $reason);
+ }
+ elsif($clearcmd =~ /^users$/i) {
+ cs_clear_users($user, { CHAN => $chan }, $reason);
+ }
+ elsif($clearcmd =~ /^bans?$/i) {
+ cs_clear_bans($user, { CHAN => $chan }, 0, $reason);
+ }
+ elsif($clearcmd =~ /^excepts?$/i) {
+ cs_clear_bans($user, { CHAN => $chan }, 128, $reason);
+ }
+ else {
+ notice($user, "Unknown CLEAR command \002$clearcmd\002",
+ 'Syntax: CLEAR <channel> <MODES|OPS|USERS|BANS> [reason]');
+ }
+ }
+ elsif($cmd =~ /^mkick$/i) {
+ my ($cmd, $chan, $reason) = split(/\s+/, $msg, 3);
+ if($chan) {
+ cs_clear_users($user, { CHAN => $chan }, $reason);
+ }
+ else {
+ notice($user, 'Syntax: MKICK <chan> [reason]');
+ }
+ }
+ elsif($cmd =~ /^mdeop$/i) {
+ my ($cmd, $chan, $reason) = split(/\s+/, $msg, 3);
+ if($chan) {
+ cs_clear_ops($user, { CHAN => $chan }, $reason);
+ }
+ else {
+ notice($user, 'Syntax: MDEOP <chan> [reason]');
+ }
+ }
+ elsif($cmd =~ /^welcome$/i) {
+ my $wcmd = splice(@args, 1, 1);
+ if(lc($wcmd) eq 'add') {
+ my ($chan, $wmsg) = (splice(@args, 0, 1), join(' ', @args));
+ unless ($chan and $wmsg) {
+ notice($user, 'Syntax: WELCOME <channel> ADD <message>');
+ return;
+ }
+ cs_welcome_add($user, { CHAN => $chan }, $wmsg);
+ }
+ elsif(lc($wcmd) eq 'del') {
+ if (@args != 2 or !misc::isint($args[1])) {
+ notice($user, 'Syntax: WELCOME <channnel> DEL <number>');
+ return;
+ }
+ cs_welcome_del($user, { CHAN => $args[0] }, $args[1]);
+ }
+ elsif(lc($wcmd) eq 'list') {
+ if (@args != 1) {
+ notice($user, 'Syntax: WELCOME <channel> LIST');
+ return;
+ }
+ cs_welcome_list($user, { CHAN => $args[0] });
+ }
+ else {
+ notice($user, 'Syntax: WELCOME <channel> <ADD|DEL|LIST>');
+ }
+ }
+ elsif($cmd =~ /^alist$/i) {
+ if(@args >= 1) {
+ cs_alist($user, { CHAN => shift @args }, shift @args);
+ } else {
+ notice($user, 'Syntax: ALIST <channel> [mask]');
+ }
+ }
+ elsif($cmd =~ /^unban$/i) {
+ if(@args == 1) {
+ cs_unban($user, { CHAN => shift @args }, $src);
+ }
+ elsif(@args >= 2) {
+ cs_unban($user, { CHAN => shift @args }, @args);
+ } else {
+ notice($user, 'Syntax: UNBAN <channel> [nick]');
+ }
+ }
+ elsif($cmd =~ /^getkey$/i) {
+ if(@args == 1) {
+ cs_getkey($user, { CHAN => $args[0] });
+ } else {
+ notice($user, 'Syntax: GETKEY <channel>');
+ }
+ }
+ elsif($cmd =~ /^auth$/i) {
+ if (@args == 0) {
+ notice($user, 'Syntax: AUTH <channel> <LIST|DELETE> [param]');
+ } else {
+ cs_auth($user, { CHAN => shift @args }, shift @args, @args);
+ }
+ }
+ elsif($cmd =~ /^dice$/i) {
+ notice($user, botserv::get_dice($args[0]));
+ }
+ elsif($cmd =~ /^(q|n)?ban$/i) {
+ my $type = $1;
+ my $chan = shift @args;
+ if(@args >= 1) {
+ cs_ban($user, { CHAN => $chan }, $type, @args)
+ }
+ else {
+ notice($user, 'Syntax: BAN <channel> <nick|mask>');
+ }
+ }
+ elsif($cmd =~ /^banlist$/i) {
+ my $chan = shift @args;
+ if(@args == 0) {
+ cs_banlist($user, { CHAN => $chan });
+ }
+ else {
+ notice($user, 'Syntax: BANLIST <channel>');
+ }
+ }
+ elsif($cmd =~ /^assign$/i) {
+ my $chan = shift @args;
+ notice($user, "$csnick ASSIGN is deprecated. Please use $botserv::bsnick ASSIGN");
+ if(@args == 2) {
+ botserv::bs_assign($user, { CHAN => shift @args }, shift @args);
+ }
+ else {
+ notice($user, 'Syntax: ASSIGN <#channel> <bot>');
+ }
+ }
+ elsif($cmd =~ /^mode$/i) {
+ my $chan = shift @args;
+ if(@args >= 1) {
+ cs_mode($user, { CHAN => $chan }, @args)
+ }
+ else {
+ notice($user, 'Syntax: MODE <channel> <modes> [parms]');
+ }
+ }
+ elsif($cmd =~ /^copy$/i) {
+ my $chan = shift @args;
+ if(@args >= 1) {
+ cs_copy($user, { CHAN => $chan }, @args)
+ }
+ else {
+ notice($user, 'Syntax: COPY #chan1 [type] #chan2');
+ }
+ }
+ elsif($cmd =~ /^m(?:ode)?lock$/i) {
+ my $chan = shift @args;
+ if(@args >= 1) {
+ cs_mlock($user, { CHAN => $chan }, @args)
+ }
+ else {
+ notice($user, 'Syntax: MLOCK <channel> <ADD|DEL|SET|RESET> <modes> [parms]');
+ }
+ }
+ elsif($cmd =~ /^resync$/i) {
+ if (@args == 0) {
+ notice($user, 'Syntax: RESYNC <chan1> [chan2 [chan3 [..]]]');
+ } else {
+ cs_resync($user, @args);
+ }
+ }
+ elsif($cmd =~ /^JOIN$/i) {
+ if (@args == 0) {
+ notice($user, 'Syntax: JOIN <chan1> [chan2 [chan3 [..]]]');
+ } else {
+ cs_join($user, @args);
+ }
+ }
+ elsif($cmd =~ /^topic$/i) {
+ my $chan = shift @args;
+ if (@args == 0) {
+ notice($user, 'Syntax: TOPIC <#channel> <message|NONE>');
+ } else {
+ $msg =~ s/^topic #(?:\S+)? //i;
+ cs_topic($user, { CHAN => $chan }, $msg);
+ }
+ }
+ elsif($cmd =~ /^topicappend$/i) {
+ my $chan = shift @args;
+ if (@args == 0) {
+ notice($user, 'Syntax: TOPICAPPEND <#channel> <message>');
+ } else {
+ $msg =~ s/^topicappend #(?:\S+)? //i;
+ cs_topicappend($user, $chan, $msg);
+ }
+ }
+ elsif($cmd =~ /^topicprepend$/i) {
+ my $chan = shift @args;
+ if (@args == 0) {
+ notice($user, 'Syntax: TOPICPREPEND <#channel> <message>');
+ } else {
+ $msg =~ s/^topicprepend #(?:\S+)? //i;
+ cs_topicprepend($user, $chan, $msg);
+ }
+ }
+ else {
+ notice($user, "Unrecognized command \002$cmd\002.", "For help, type: \002/msg chanserv help\002");
+ wlog($csnick, LOG_DEBUG(), "$src tried to use $csnick $msg");
+ }
+}
+
+sub cs_register($$;$$) {
+ my ($user, $chan, $pass, $desc) = @_;
+ # $pass is still passed in, but never used!
+ my $src = get_user_nick($user);
+ my $cn = $chan->{CHAN};
+
+ unless(is_identified($user, $src)) {
+ notice($user, 'You must register your nickname first.', "Type \002/msg NickServ HELP\002 for information on registering nicknames.");
+ return;
+ }
+
+ unless(is_in_chan($user, $chan)) {
+ notice($user, "You are not in \002$cn\002.");
+ return;
+ }
+
+ if(services_conf_chanreg_needs_oper && !adminserv::is_svsop($user)) {
+ notice($user, "You must be network staff to register a channel\n");
+ return;
+ }
+ unless(get_op($user, $chan) & ($opmodes{o} | $opmodes{a} | $opmodes{q})) {
+ # This would be preferred to be a 'opmode_mask' or something
+ # However that might be misleading due to hop not being enough to register
+ notice($user, "You must have channel operator status to register \002$cn\002.");
+ return;
+ }
+
+ my $root = get_root_nick($src);
+
+ if($desc) {
+ my $dlength = length($desc);
+ if($dlength >= 350) {
+ notice($user, 'Channel description is too long by '. $dlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+ }
+
+ if($register->execute($cn, $desc, $root)) {
+ notice($user, "\002Your channel is now registered. Thank you.\002");
+ notice($user, ' ', "\002NOTICE:\002 Channel passwords are not used, as a security precaution.")
+ if $pass;
+ set_acc($root, $user, $chan, FOUNDER);
+ $set_modelock->execute(services_conf_default_channel_mlock, $cn);
+ do_modelock($chan);
+ services::ulog($csnick, LOG_INFO(), "registered $cn", $user, $chan);
+ botserv::bs_assign($user, $chan, services_conf_default_chanbot) if services_conf_default_chanbot;
+ } else {
+ notice($user, 'That channel has already been registered.');
+ }
+}
+
+=cut
+cs_command new SrSv::AgentUI::Simple {
+ COMMAND => [qw(uop vop hop aop sop cf cofounder cof cfounder)],
+ SYNTAX => '#chan add/del/list/wipe/clear [nick/mask]',
+ CALL => \&cs_xop_dispatch,
+ CMD_TOO => 1,
+};
+=cut
+sub cs_xop_dispatch {
+ my ($user, $cmd, $chan, $cmd2, @args) = @_;
+ $cmd = uc $cmd;
+
+ if($cmd2 =~ /^add$/i) {
+ if(@args == 1) {
+ cs_xop_add($user, $chan, $cmd, $args[0]);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> ADD <nick>');
+ }
+ }
+ elsif($cmd2 =~ /^del(ete)?$/i) {
+ if(@args == 1) {
+ cs_xop_del($user, $chan, $cmd, $args[0]);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> DEL <nick>');
+ }
+ }
+ elsif($cmd2 =~ /^list$/i) {
+ if(@args >= 0) {
+ cs_xop_list($user, $chan, $cmd, $args[0]);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> LIST [mask]');
+ }
+ }
+ elsif($cmd2 =~ /^(wipe|clear)$/i) {
+ if(@args == 0) {
+ cs_xop_wipe($user, $chan, $cmd);
+ } else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> WIPE');
+ }
+ }
+ else {
+ notice($user, 'Syntax: '.uc $cmd.' <#channel> <ADD|DEL|LIST|WIPE>');
+ }
+}
+
+sub cs_xop_ad_pre($$$$$) {
+ my ($user, $chan, $nick, $level, $del) = @_;
+
+ my $old = get_acc($nick, $chan); $old = 0 unless $old;
+ my $slevel = get_best_acc($user, $chan);
+
+ unless(($del and is_identified($user, $nick)) or adminserv::can_do($user, 'SERVOP')) {
+ unless($level < $slevel and $old < $slevel) {
+ notice($user, $err_deny);
+ return undef;
+ }
+ my $cn = $chan->{CHAN};
+ my $overrideMsg = "$levels[$level] $cn ".($del ? 'DEL' : 'ADD')." $nick";
+ can_do($chan, 'ACCCHANGE', $user, { OVERRIDE_MSG => $overrideMsg }) or return undef;
+ }
+
+ nickserv::chk_registered($user, $nick) or return undef;
+ if (nr_chk_flag($nick, NRF_NOACC()) and !adminserv::can_do($user, 'SERVOP') and !$del) {
+ notice($user, "\002$nick\002 is not able to be added to access lists.");
+ return undef;
+ }
+
+ return $old;
+}
+
+sub cs_xop_list($$$;$) {
+ my ($user, $chan, $cmd, $mask) = @_;
+ chk_registered($user, $chan) or return;
+ my $cn = $chan->{CHAN};
+ my $level = xop_byname($cmd);
+
+ my $overrideMsg = "$cmd $cn LIST";
+ can_do($chan, 'ACCLIST', $user, { OVERRIDE_MSG => $overrideMsg }) or return;
+
+ my @reply;
+ if($mask) {
+ my ($mnick, $mident, $mhost) = glob2sql(parse_mask($mask));
+ $mnick = '%' if($mnick eq '');
+ $mident = '%' if($mident eq '');
+ $mhost = '%' if($mhost eq '');
+
+ $get_acc_list_mask->execute($mnick, $cn, $level, $mnick, $mident, $mhost);
+ while(my ($n, $a, $t, $lu, $id, $vh) = $get_acc_list_mask->fetchrow_array) {
+ push @reply, "*) $n ($id\@$vh)" . ($a ? ' Added by: '.$a : '');
+ push @reply, ' '.($t ? 'Date/time added: '. gmtime2($t).' ' : '').
+ ($lu ? 'Last used '.time_ago($lu).' ago' : '') if ($t or $lu);
+ }
+ $get_acc_list_mask->finish();
+ } else {
+ $get_acc_list->execute($cn, $level);
+ while(my ($n, $a, $t, $lu, $id, $vh) = $get_acc_list->fetchrow_array) {
+ push @reply, "*) $n ($id\@$vh)" . ($a ? ' Added by: '.$a : '');
+ push @reply, ' '.($t ? 'Date/time added: '. gmtime2($t).' ' : '').
+ ($lu ? 'Last used '.time_ago($lu).' ago' : '') if ($t or $lu);
+ }
+ $get_acc_list->finish();
+ }
+
+ notice($user, "$levels[$level] list for \002$cn\002:", @reply);
+
+ return;
+}
+
+sub cs_xop_wipe($$$) {
+ my ($user, $chan, $cmd, $nick) = @_;
+ chk_registered($user, $chan) or return;
+
+ my $slevel = get_best_acc($user, $chan);
+ my $level = xop_byname($cmd);
+
+ unless($level < $slevel) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $cn = $chan->{CHAN};
+ my $overrideMsg = "$cmd $cn WIPE";
+ my $srcnick = can_do($chan, 'ACCCHANGE', $user, { ACC => $slevel, OVERRIDE_MSG => $overrideMsg }) or return;
+
+ $wipe_acc_list->execute($cn, $level);
+
+ my $log_str = "wiped the $cmd list of \002$cn\002.";
+ my $src = get_user_nick($user);
+ notice($user, "You have $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 has $log_str")
+ if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+
+ memolog($chan, "\002$srcnick\002 $log_str");
+}
+
+sub cs_xop_add($$$$) {
+ my ($user, $chan, $cmd, $nick) = @_;
+
+ chk_registered($user, $chan) or return;
+ my $level = xop_byname($cmd);
+ my $old = cs_xop_ad_pre($user, $chan, $nick, $level, 0);
+ return unless defined($old);
+
+ my $cn = $chan->{CHAN};
+
+ if($old == $level) {
+ notice($user, "\002$nick\002 already has $levels[$level] access to \002$cn\002.");
+ return;
+ }
+
+ if($old == FOUNDER) {
+ notice($user, "\002$nick\002 is the founder of \002$cn\002 and cannot be added to access lists.",
+ "For more information, type: \002/msg chanserv help set founder\002");
+ return;
+ }
+
+ my $root = get_root_nick($nick);
+ my $auth = nr_chk_flag($root, NRF_AUTH());
+ my $src = get_user_nick($user);
+
+ if($auth) {
+ $add_auth->execute($cn, "$src:".($old ? $old : 0 ).":$level:".time(), $root);
+ del_acc($root, $chan) if $level < $old;
+ }
+ else {
+ set_acc($root, $user, $chan, $level);
+ }
+
+ if($old < 0) {
+ $del_nick_akick->execute($cn, $root);
+ my $log_str = "moved $root from the AKICK list to the ${levels[$level]} list of \002$cn\002".
+ ($auth ? ' (requires authorization)' : '');
+
+ my $src = get_user_nick($user);
+ notice_all_nicks($user, $root, "\002$src\002 $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 $log_str")
+ if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+ my $srcnick = can_do($chan, 'ACCLIST', $user);
+ memolog($chan, "\002$srcnick\002 $log_str");
+ } else {
+ my $log_str = ($old?'moved':'added')." \002$root\002"
+ . ($old ? " from the ${levels[$old]}" : '') .
+ " to the ${levels[$level]} list of \002$cn\002" .
+ ($auth ? ' (requires authorization)' : '');
+ my $src = get_user_nick($user);
+ notice_all_nicks($user, $root, "\002$src\002 $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 $log_str")
+ if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+ my $srcnick = can_do($chan, 'ACCLIST', $user);
+ memolog($chan, "\002$srcnick\002 $log_str");
+ }
+}
+
+sub cs_xop_del($$$) {
+ my ($user, $chan, $cmd, $nick) = @_;
+
+ chk_registered($user, $chan) or return;
+ my $level = xop_byname($cmd);
+ my $old = cs_xop_ad_pre($user, $chan, $nick, $level, 1);
+ return unless defined($old);
+
+ my $cn = $chan->{CHAN};
+
+ unless($old == $level) {
+ notice($user, "\002$nick\002 is not on the ${levels[$level]} list of \002$cn\002.");
+ return;
+ }
+
+ my $root = get_root_nick($nick);
+ my $srcnick = can_do($chan, 'ACCLIST', $user);
+
+ del_acc($root, $chan);
+
+ my $src = get_user_nick($user);
+ my $log_str = "removed \002$root\002 ($nick) from the ${levels[$level]} list of \002$cn\002";
+ notice_all_nicks($user, $root, "\002$src\002 $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 $log_str")
+ if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+ memolog($chan, "\002$srcnick\002 $log_str");
+}
+
+sub cs_count($$) {
+ my ($user, $chan) = @_;
+
+ chk_registered($user, $chan) or return;
+
+ my $cn = $chan->{CHAN};
+ my $overrideMsg = "COUNT $cn";
+ if(can_do($chan, 'ACCLIST', $user, { OVERRIDE_MSG => $overrideMsg })) {
+ } else {
+ return;
+ }
+
+ my $reply = '';
+ for (my $level = $plzero + 1; $level < COFOUNDER + 2; $level++) {
+ $get_acc_count->execute($cn, $level - 1);
+ my ($num_recs) = $get_acc_count->fetchrow_array;
+ $reply = $reply." $plevels[$level]: ".$num_recs;
+ }
+ notice($user, "\002$cn Count:\002 ".$reply);
+}
+
+sub cs_levels_pre($$$;$) {
+ my($user, $chan, $cmd, $listonly) = @_;
+
+ chk_registered($user, $chan) or return 0;
+ my $cn = $chan->{CHAN};
+ my $overrideMsg = "LEVELS $cn $cmd";
+ return can_do($chan, ($listonly ? 'LEVELSLIST' : 'LEVELS'), $user, { OVERRIDE_MSG => $overrideMsg });
+}
+
+sub cs_levels_set($$$;$) {
+ my ($user, $chan, $perm, $level) = @_;
+
+ cs_levels_pre($user, $chan, "$perm $level") or return;
+ my $cn = $chan->{CHAN};
+
+ unless(is_level($perm)) {
+ notice($user, "$perm is not a valid permission.");
+ return;
+ }
+
+ if(defined($level)) {
+ $level = xop_byname($level);
+ unless(defined($level) and $level >= 0) {
+ notice($user, 'You must specify one of the following levels: '.
+ 'any, uop, vop, hop, aop, sop, cofounder, founder, nobody');
+ return;
+ }
+
+ $get_level_max->execute($perm);
+ my ($max) = $get_level_max->fetchrow_array;
+ $get_level_max->finish();
+
+ if($max and $level > $max) {
+ notice($user, "\002$perm\002 cannot be set to " . $plevels[$level+$plzero] . '.');
+ return;
+ }
+
+ $add_level->execute($cn, $perm);
+ $set_level->execute($level, $cn, $perm);
+
+ if($level == 8) {
+ notice($user, "\002$perm\002 is now disabled in \002$cn\002.");
+ } else {
+ notice($user, "\002$perm\002 now requires " . $levels[$level] . " access in \002$cn\002.");
+ }
+ } else {
+ $reset_level->execute($perm, $cn);
+
+ notice($user, "\002$perm\002 has been reset to default.");
+ }
+}
+
+sub cs_levels_list($$) {
+ my ($user, $chan) = @_;
+
+ cs_levels_pre($user, $chan, 'LIST', 1) or return;
+ my $cn = $chan->{CHAN};
+
+ $get_levels->execute($cn);
+ my @data;
+ while(my ($name, $def, $lvl) = $get_levels->fetchrow_array) {
+ push @data, [$name,
+ (defined($lvl) ? $plevels[$lvl+$plzero] : $plevels[$def+$plzero]),
+ (defined($lvl) ? '' : '(default)')];
+ }
+
+ notice($user, columnar { TITLE => "Permission levels for \002$cn\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT) }, @data);
+}
+
+sub cs_levels_clear($$) {
+ my ($user, $chan) = @_;
+
+ cs_levels_pre($user, $chan, 'CLEAR') or return;
+ my $cn = $chan->{CHAN};
+
+ $clear_levels->execute($cn);
+
+ notice($user, "All permissions have been reset to default.");
+}
+
+sub cs_akick_pre($$$;$) {
+ my ($user, $chan, $overrideMsg, $list) = @_;
+
+ chk_registered($user, $chan) or return 0;
+
+ return can_do($chan, ($list ? 'AKICKLIST' : 'AKICK'), $user, { OVERRIDE_MSG => $overrideMsg });
+}
+
+sub cs_akick_add($$$$) {
+ my ($user, $chan, $mask, $reason) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $adder = cs_akick_pre($user, $chan, "ADD $mask $reason") or return;
+
+ my ($nick, $ident, $host) = parse_mask($mask);
+
+ if(($ident eq '' or $host eq '') and not ($ident eq '' and $host eq '')) {
+ notice($user, 'Invalid hostmask.');
+ return;
+ }
+
+ if($ident eq '') {
+ $nick = $mask;
+
+ unless(valid_nick($nick)) {
+ $mask = normalize_hostmask($mask);
+ ($nick, $ident, $host) = parse_mask($mask);
+ }
+ }
+
+ if ($ident eq '' and $host eq '' and !nickserv::is_registered($nick)) {
+ notice($user, "\002$nick\002 is not registered");
+ return;
+ }
+
+ my $rlength = length($reason);
+ if($rlength >= 350) {
+ notice($user, 'AKick reason is too long by '. $rlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ my $log_str;
+ my $src = get_user_nick($user);
+ if($ident eq '' and $host eq '' and my $old = get_acc($nick, $chan)) {
+ if ($old == -1) {
+ notice($user, "\002$nick\002 is already on the AKick list in \002$cn\002");
+ return;
+ }
+ if($old < get_best_acc($user, $chan) or adminserv::can_do($user, 'SERVOP')) {
+ if ($old == FOUNDER()) {
+ # This is a fallthrough for the override case.
+ # It shouldn't happen otherwise.
+ # I didn't make it part of the previous conditional
+ # b/c just $err_deny is a bit undescriptive in the override case.
+ notice($user, "You can't akick the founder!", $err_deny);
+ return;
+ }
+
+ my $root = get_root_nick($nick);
+ $add_nick_akick->execute($cn, $src, $reason, $nick); $add_nick_akick->finish();
+ set_acc($nick, $user, $chan, -1);
+ $log_str = "moved \002$nick\002 (root: \002$root\002) from the $levels[$old] list".
+ " to the AKick list of \002$cn\002";
+ notice_all_nicks($user, $root, "\002$src\002 $log_str");
+ } else {
+ notice($user, $err_deny);
+ return;
+ }
+ } else {
+ if($ident eq '' and $host eq '') {
+ $add_nick_akick->execute($cn, $src, $reason, $nick); $add_nick_akick->finish();
+ if (find_auth($cn, $nick)) {
+ # Don't allow a pending AUTH entry to potentially override an AKick entry
+ # Believe it or not, it almost happened with #animechat on SCnet.
+ # This would also end up leaving an orphan entry in the akick table.
+ $nickserv::del_auth->execute($nick, $cn);
+ $nickserv::del_auth->finish();
+ }
+ set_acc($nick, $user, $chan, -1);
+ my $root = get_root_nick($nick);
+ $log_str = "added \002$nick\002 (root: \002$root\002) to the AKick list of \002$cn\002.";
+ } else {
+ ($nick, $ident, $host) = glob2sql($nick, $ident, $host);
+ unless($add_akick->execute($cn, $nick, $ident, $host, $adder, $reason)) {
+ notice($user, "\002$mask\002 is already on the AKick list of \002$cn\002.");
+ return;
+ }
+ $log_str = "added \002$mask\002 to the AKick list of \002$cn\002.";
+ }
+
+ }
+ notice($user, "You have $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 $log_str")
+ if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+ memolog($chan, "\002$adder\002 $log_str");
+
+ akick_allchan($chan);
+}
+
+sub get_akick_by_num($$) {
+ my ($chan, $num) = @_;
+ my $cn = $chan->{CHAN};
+
+ $get_akick_by_num->execute($cn, $num);
+ my ($nick, $ident, $host) = $get_akick_by_num->fetchrow_array();
+ ($nick, $ident, $host) = sql2glob($nick, $ident, $host);
+ $get_akick_by_num->finish();
+ if(!$nick) {
+ return undef;
+ } elsif($ident eq '' and $host eq '') {
+ # nick based akicks don't use nicks but nickreg.id
+ # so we have to get the nickreg.nick back
+ $nick = nickserv::get_id_nick($nick);
+ }
+ return ($nick, $ident, $host);
+}
+
+sub cs_akick_del($$$) {
+ my ($user, $chan, $mask) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $adder = cs_akick_pre($user, $chan, "DEL $mask") or return;
+
+ my @masks;
+ if ($mask =~ /^[0-9\.,-]+$/) {
+ foreach my $num (makeSeqList($mask)) {
+ my ($nick, $ident, $host) = get_akick_by_num($chan, $num - 1) or next;
+ if($ident eq '' and $host eq '') {
+ push @masks, $nick;
+ } else {
+ push @masks, "$nick!$ident\@$host";
+ }
+ }
+ } else {
+ @masks = ($mask);
+ }
+ foreach my $mask (@masks) {
+ my ($nick, $ident, $host) = parse_mask($mask);
+
+ if(($ident eq '' or $host eq '') and not ($ident eq '' and $host eq '')) {
+ notice($user, 'Invalid hostmask.');
+ return;
+ }
+
+ if($ident eq '') {
+ $nick = $mask;
+
+ unless(valid_nick($nick)) {
+ $mask = normalize_hostmask($mask);
+ ($nick, $ident, $host) = parse_mask($mask);
+ }
+ }
+
+ if ($ident eq '' and $host eq '' and !nickserv::is_registered($nick)) {
+ notice($user, "\002$nick\002 is not registered");
+ return;
+ }
+
+ my ($success, $log_str) = do_akick_del($chan, $mask, $nick, $ident, $host);
+ my $src = get_user_nick($user);
+ if($success) {
+ notice($user, "\002$src\002 $log_str");
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 $log_str") if cr_chk_flag($chan, CRF_VERBOSE);
+ memolog($chan, "\002$adder\002 $log_str");
+ } else {
+ notice($user, $log_str);
+ }
+ }
+}
+
+sub do_akick_del($$$$$) {
+ my ($chan, $mask, $nick, $ident, $host) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $log_str;
+ if($ident eq '' and $host eq '') {
+ if(get_acc($nick, $chan) == -1) {
+ del_acc($nick, $chan);
+ $del_nick_akick->execute($cn, $nick); $del_nick_akick->finish();
+ my $root = get_root_nick($nick);
+ return (1, "deleted \002$nick\002 (root: \002$root\002) from the AKick list of \002$cn\002.")
+ } else {
+ return (undef, "\002$mask\002 was not on the AKick list of \002$cn\002.");
+ }
+ } else {
+ ($nick, $ident, $host) = glob2sql($nick, $ident, $host);
+ if($del_akick->execute($cn, $nick, $ident, $host) != 0) {
+ return (1, "deleted \002$mask\002 from the AKick list of \002$cn\002.");
+ } else {
+ return (undef, "\002$mask\002 was not on the AKick list of \002$cn\002.");
+ }
+ }
+}
+
+sub cs_akick_list($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ cs_akick_pre($user, $chan, 'LIST', 1) or return;
+
+ my @data;
+
+ $get_akick_list->execute($cn);
+ my $i = 0;
+ while(my ($nick, $ident, $host, $adder, $reason, $time) = $get_akick_list->fetchrow_array) {
+ if($ident ne '') {
+ ($nick, $ident, $host) = sql2glob($nick, $ident, $host);
+ }
+
+ if($ident eq '' and $host eq '') {
+ $nick = nickserv::get_id_nick($nick);
+ } else {
+ $nick = "$nick!$ident\@$host";
+ }
+
+ push @data, ["\002".++$i."\002", $nick, $adder, ($time ? gmtime2($time) : ''), $reason];
+ }
+
+ notice($user, columnar {TITLE => "AKICK list of \002$cn\002:", DOUBLE=>1,
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+}
+
+sub cs_akick_wipe($$$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $adder = cs_akick_pre($user, $chan, 'WIPE') or return;
+
+ $drop_akick->execute($cn);
+ $wipe_acc_list->execute($cn, -1);
+ my $log_str = "wiped the AKICK list of \002$cn\002.";
+ my $src = get_user_nick($user);
+ notice($user, "You have $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "\002$src\002 $log_str") if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($csnick, LOG_INFO(), $log_str, $user, $chan);
+ memolog($chan, "\002$adder\002 $log_str");
+}
+
+sub cs_akick_enforce($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ chk_registered($user, $chan) or return;
+
+ can_do($chan, 'AKickEnforce', $user, { OVERRIDE_MSG => "AKICK $cn ENFORCE" }) or return;
+
+ akick_allchan($chan);
+}
+
+=cut
+cs_command new SrSv::AgentUI::Simple {
+ COMMAND => [qw(info)],
+ SYNTAX => 'LIST:#chan',
+ CALL => \&cs_info,
+ NO_WRAPPER => 1,
+};
+=cut
+sub cs_info($@) {
+ my ($user, @chanList) = @_;
+
+ my @reply;
+ foreach my $cn (@chanList) {
+ if(ref($cn) eq 'HASH') {
+ $cn = $cn->{CHAN};
+ }
+ elsif($cn =~ /,/) {
+ push @chanList, split(',', $cn);
+ next;
+ }
+ my $chan = { CHAN => $cn };
+ unless(__can_do($chan, 'INFO', undef, 0)) {
+ can_do($chan, 'INFO', $user, { OVERRIDE_MSG => "INFO $cn" })
+ or next;
+ }
+
+ $get_info->execute($cn);
+ my @result = $get_info->fetchrow_array;
+ unless(@result) {
+ push @reply, "The channel \002$cn\002 is not registered.";
+ next;
+ }
+
+ my ($descrip, $regd, $last, $topic, $topicer, $modelock, $founder, $successor, $bot, $bantype,$bantime) = @result;
+
+ $modelock = modes::sanitize($modelock) unless can_do($chan, 'GETKEY', $user, { NOREPLY => 1 });
+
+ my @opts;
+
+ my $topiclock = get_level($chan, 'SETTOPIC');
+ push @opts, "Topic Lock ($levels[$topiclock])" if $topiclock;
+
+ if(cr_chk_flag($chan, (CRF_CLOSE | CRF_DRONE))) {
+ push @reply, "\002$cn\002 is closed and cannot be used: ". get_close($chan);
+ next;
+ }
+
+ my @extra;
+ push @extra, 'Will not expire' if cr_chk_flag($chan, CRF_HOLD);
+ push @extra, 'Channel is frozen and access suspended' if cr_chk_flag($chan, CRF_FREEZE);
+
+ push @opts, 'OpGuard' if cr_chk_flag($chan, CRF_OPGUARD);
+ push @opts, 'BotStay' if cr_chk_flag($chan, CRF_BOTSTAY);
+ push @opts, 'SplitOps' if cr_chk_flag($chan, CRF_SPLITOPS);
+ push @opts, 'Verbose' if cr_chk_flag($chan, CRF_VERBOSE);
+ push @opts, 'NeverOp' if cr_chk_flag($chan, CRF_NEVEROP);
+ push @opts, 'Ban type '.$bantype if $bantype;
+ push @opts, 'Ban time '.$bantime . ' seconds' if $bantype;
+ my $opts = join(', ', @opts);
+
+ my @data;
+
+ push @data, ['Founder:', $founder];
+ push @data, ['Successor:', $successor] if $successor;
+ push @data, ['Description:', $descrip] if $descrip;
+ push @data, ['Mode lock:', $modelock];
+ push @data, ['Settings:', $opts] if $opts;
+ push @data, ['ChanBot:', $bot] if $bot and $bot ne '';
+ #FIXME: memo level
+ push @data, ['Registered:', gmtime2($regd)],
+ ['Last opping:', gmtime2($last)],
+ ['Time now:', gmtime2(time)];
+
+ push @reply, columnar {TITLE => "ChanServ info for \002$cn\002:", NOHIGHLIGHT => 1}, @data,
+ {COLLAPSE => \@extra, BULLET => 1};
+ }
+ notice($user, @reply);
+}
+
+sub cs_set_pre($$$$) {
+ my ($user, $chan, $set, $parm) = @_;
+ my $cn = $chan->{CHAN};
+ my $override = 0;
+
+ my %valid_set = (
+ 'founder' => 1, 'successor' => 1, 'unsuccessor' => 1,
+ #'mlock' => 1, 'modelock' => 1,
+ 'desc' => 1,
+ 'topiclock' => 1, 'greet' => 1, 'opguard' => 1,
+ 'freeze' => 1, 'botstay' => 1, 'verbose' => 1,
+ 'splitops' => 1, 'bantype' => 1, 'dice' => 1,
+ 'welcomeinchan' => 1, 'log' => 1,
+
+ 'hold' => 1, 'noexpire' => 1, 'no-expire' => 1,
+
+ 'autovoice' => 1, 'avoice' => 1,
+ 'neverop' => 1, 'noop' => 1,
+ 'noclones' => 1,
+ 'bantime' => 1,
+ );
+ my %override_set = (
+ 'hold' => 'SERVOP', 'noexpire' => 'SERVOP', 'no-expire' => 'SERVOP',
+ 'freeze' => 'FREEZE', 'botstay' => 'BOT', 'log' => 'LOG',
+ );
+
+ chk_registered($user, $chan) or return 0;
+ if($set =~ /m(?:ode)?lock/) {
+ notice($user, "CS SET MLOCK is deprecated and replaced with CS MLOCK",
+ "For more information, please /CS HELP MLOCK");
+ return 0;
+ }
+ unless($valid_set{lc $set}) {
+ notice($user, "$set is not a valid ChanServ setting.");
+ return 0;
+ }
+
+ if($override_set{lc($set)}) {
+ if(adminserv::can_do($user, $override_set{lc($set)}) ) {
+ if(services_conf_log_overrides) {
+ my $src = get_user_nick($user);
+ wlog($csnick, LOG_INFO(), "\002$src\002 used override CS SET $cn $set $parm");
+ }
+ $override = 1;
+ } else {
+ notice($user, $err_deny);
+ return 0;
+ }
+ }
+ else {
+ can_do($chan, 'SET', $user) or return 0;
+ }
+
+ return 1;
+}
+
+sub cs_set($$$;$) {
+ my ($user, $chan, $set, $parm) = @_;
+ my $cn = $chan->{CHAN};
+ $set = lc $set;
+
+ cs_set_pre($user, $chan, $set, $parm) or return;
+
+ if($set =~ /^founder$/i) {
+ my $override;
+ unless(get_best_acc($user, $chan) == FOUNDER) {
+ if(adminserv::can_do($user, 'SERVOP')) {
+ $override = 1;
+ } else {
+ notice($user, $err_deny);
+ return;
+ }
+ }
+
+ my $root;
+ unless($root = get_root_nick($parm)) {
+ notice($user, "The nick \002$parm\002 is not registered.");
+ return;
+ }
+
+ $get_founder->execute($cn);
+ my ($prev) = $get_founder->fetchrow_array;
+ $get_founder->finish();
+
+ if(lc($root) eq lc($prev)) {
+ notice($user, "\002$parm\002 is already the founder of \002$cn\002.");
+ return;
+ }
+
+ set_acc($prev, $user, $chan, COFOUNDER);
+
+ $set_founder->execute($root, $cn); $set_founder->finish();
+ set_acc($root, $user, $chan, FOUNDER);
+
+ notice($user, ($override ? "The previous founder, \002$prev\002, has" : "You have") . " been moved to the co-founder list of \002$cn\002.");
+ notice_all_nicks($user, $root, "\002$root\002 has been set as the founder of \002$cn\002.");
+ services::ulog($csnick, LOG_INFO(), "set founder of \002$cn\002 to \002$root\002", $user, $chan);
+
+ $get_successor->execute($cn);
+ my $suc = $get_successor->fetchrow_array; $get_successor->finish();
+ if(lc($suc) eq lc($root)) {
+ $del_successor->execute($cn); $del_successor->finish();
+ notice($user, "Successor has been removed from \002$cn\002.");
+ }
+
+ return;
+ }
+
+ if($set eq 'successor') {
+ unless(get_best_acc($user, $chan) == FOUNDER or adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if(get_acc($parm, $chan) == 7) {
+ notice($user, "The channel founder may not be the successor.");
+ return;
+ }
+
+ my $root;
+ unless($root = get_root_nick($parm)) {
+ notice($user, "The nick \002$parm\002 is not registered.");
+ return;
+ }
+
+ $set_successor->execute($root, $cn); $set_successor->finish();
+
+ notice($user, "\002$parm\002 is now the successor of \002$cn\002");
+ services::ulog($csnick, LOG_INFO(), "set successor of \002$cn\002 to \002$root\002", $user, $chan);
+ return;
+ }
+
+ if($set eq 'unsuccessor') {
+ unless(get_best_acc($user, $chan) == FOUNDER or adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ $del_successor->execute($cn); $del_successor->finish();
+
+ notice($user, "Successor has been removed from \002$cn\002.");
+ services::ulog($csnick, LOG_INFO(), "removed successor from \002$cn\002", $user, $chan);
+ return;
+ }
+
+ if($set =~ /m(?:ode)?lock/) {
+ my $modes = modes::merge($parm, '+r', 1);
+ $modes = sanitize_mlockable($modes);
+ $set_modelock->execute($modes, $cn);
+
+ notice($user, "Mode lock for \002$cn\002 has been set to: \002$modes\002");
+ do_modelock($chan);
+ return;
+ }
+
+ if($set eq 'desc') {
+ $set_descrip->execute($parm, $cn);
+
+ notice($user, "Description of \002$cn\002 has been changed.");
+ return;
+ }
+
+ if($set eq 'topiclock') {
+ my $perm = xop_byname($parm);
+ if($parm =~ /^(?:no|off|false|0)$/i) {
+ cs_levels_set($user, $chan, 'SETTOPIC');
+ cs_levels_set($user, $chan, 'TOPIC');
+ } elsif($perm >= 0 and defined($perm)) {
+ cs_levels_set($user, $chan, 'SETTOPIC', $parm);
+ cs_levels_set($user, $chan, 'TOPIC', $parm);
+ } else {
+ notice($user, 'Syntax: SET <#chan> TOPICLOCK <off|any|uop|vop|hop|aop|sop|cf|founder>');
+ }
+ return;
+ }
+
+ if($set =~ /^bantype$/i) {
+ unless (misc::isint($parm) and ($parm >= 0 and $parm <= 10)) {
+ notice($user, 'Invalid bantype');
+ return;
+ }
+
+ $set_bantype->execute($parm, $cn);
+
+ notice($user, "Ban-Type for \002$cn\002 now set to \002$parm\002.");
+
+ return;
+ }
+ if($set =~ /^bantime$/i) {
+ if ( ( my $p = substr($parm, 0, 1) ) != '+' ) {
+ $parm = '+' . $parm;
+ }
+ my $time = $parm;
+ unless ($time == 0) {
+ $time = parse_time ($parm);
+ if(!$time) {
+ notice ($user, "Invalid bantime. See /msg chanserv help set bantime for examples.");
+ return;
+ }
+ }
+ $set_bantime->execute($time, $cn);
+ notice($user, "Ban time for \002$cn\002 now set to \002$time\002 seconds.");
+ return;
+ }
+ my $val;
+ if($parm =~ /^(?:no|off|false|0)$/i) { $val = 0; }
+ elsif($parm =~ /^(?:yes|on|true|1)$/i) { $val = 1; }
+ else {
+ notice($user, "Please say \002on\002 or \002off\002.");
+ return;
+ }
+ if ($set =~ /^(?:noclones)$/i) {
+ cr_set_flag($chan, CRF_NOCLONES, $val);
+ if($val) {
+ notice($user,
+ "Noclones is now \002ON\002.",
+ "Clones will be kicked out of \002$cn\002."
+ );
+ } else {
+ notice($user,
+ "Noclones is now \002OFF\002.",
+ "People are allowed to bring clones in \002$cn\002."
+ );
+ }
+ }
+ if($set =~ /^(?:opguard|secureops)$/i) {
+ cr_set_flag($chan, CRF_OPGUARD, $val);
+
+ if($val) {
+ notice($user,
+ "OpGuard is now \002ON\002.",
+ "Channel status may not be granted by unauthorized users in \002$cn\002."#,
+ #"Note that you must change the $csnick LEVELS settings for VOICE, HALFOP, OP, and/or ADMIN for this setting to have any effect."
+ );
+ } else {
+ notice($user,
+ "OpGuard is now \002OFF\002.",
+ "Channel status may be given freely in \002$cn\002."
+ );
+ }
+
+ return;
+ }
+
+ if($set =~ /^(?:splitops)$/i) {
+ cr_set_flag($chan, CRF_SPLITOPS, $val);
+
+ if($val) {
+ notice($user, "SplitOps is now \002ON\002.");
+ } else {
+ notice($user, "SplitOps is now \002OFF\002.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^(hold|no-?expire)$/i) {
+ cr_set_flag($chan, CRF_HOLD, $val);
+
+ if($val) {
+ notice($user, "\002$cn\002 will not expire");
+ services::ulog($csnick, LOG_INFO(), "has held \002$cn\002", $user, $chan);
+ } else {
+ notice($user, "\002$cn\002 is no longer held from expiration");
+ services::ulog($csnick, LOG_INFO(), "has removed \002$cn\002 from hold", $user, $chan);
+ }
+
+ return;
+ }
+
+ if($set =~ /^freeze$/i) {
+ cr_set_flag($chan, CRF_FREEZE, $val);
+
+ if($val) {
+ notice($user, "\002$cn\002 is now frozen and access suspended");
+ services::ulog($csnick, LOG_INFO(), "has frozen \002$cn\002", $user, $chan);
+ } else {
+ notice($user, "\002$cn\002 is now unfrozen and access restored");
+ services::ulog($csnick, LOG_INFO(), "has unfrozen \002$cn\002", $user, $chan);
+ }
+
+ return;
+ }
+
+ if($set =~ /^botstay$/i) {
+ cr_set_flag($chan, CRF_BOTSTAY, $val);
+
+ if($val) {
+ notice($user, "Bot will now always stay in \002$cn");
+ botserv::bot_join($chan, undef);
+ } else {
+ notice($user, "Bot will now part if less than one user is in \002$cn");
+ botserv::bot_part_if_needed(undef, $chan, "Botstay turned off");
+ }
+
+ return;
+ }
+ if($set =~ /^verbose$/i) {
+ cr_set_flag($chan, CRF_VERBOSE, $val);
+
+ if($val) {
+ notice($user, "Verbose mode enabled on \002$cn");
+ }
+ else {
+ notice($user, "Verbose mode disabled on \002$cn");
+ }
+ return;
+ }
+
+ if($set =~ /^greet$/i) {
+ if($val) {
+ notice($user, "$csnick SET $cn GREET ON is deprecated.",
+ "Please use $csnick LEVELS $cn SET GREET <rank>");
+ } else {
+ cs_levels_set($user, $chan, 'GREET', 'nobody');
+ }
+
+ return;
+ }
+
+ if($set =~ /^dice$/i) {
+ if($val) {
+ notice($user, "$csnick SET $cn DICE ON is deprecated.",
+ "Please use $csnick LEVELS $cn SET DICE <rank>");
+ } else {
+ cs_levels_set($user, $chan, 'DICE', 'nobody');
+ }
+
+ return;
+ }
+
+ if($set =~ /^welcomeinchan$/i) {
+ cr_set_flag($chan, CRF_WELCOMEINCHAN(), $val);
+
+ if($val) {
+ notice($user, "WELCOME messages will be put in the channel.");
+ } else {
+ notice($user, "WELCOME messages will be sent privately.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^log$/i) {
+ unless(module::is_loaded('logserv')) {
+ notice($user, "module logserv is not loaded, logging is not available.");
+ return;
+ }
+
+ if($val) {
+ logserv::addchan($user, $cn) and cr_set_flag($chan, CRF_LOG, $val);
+ }
+ else {
+ logserv::delchan($user, $cn) and cr_set_flag($chan, CRF_LOG, $val);
+ }
+ return;
+ }
+
+ if($set =~ /^a(?:uto)?voice$/i) {
+ cr_set_flag($chan, CRF_AUTOVOICE(), $val);
+
+ if($val) {
+ notice($user, "All users w/o access will be autovoiced on join.");
+ } else {
+ notice($user, "AUTOVOICE disabled.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^(?:never|no)op$/i) {
+ cr_set_flag($chan, CRF_NEVEROP(), $val);
+
+ if($val) {
+ notice($user, "Users will not be automatically opped on join.");
+ } else {
+ notice($user, "Users with access will now be automatically opped on join.");
+ }
+
+ return;
+ }
+}
+
+sub cs_why($$@) {
+ my ($user, $chan, @tnicks) = @_;
+
+ chk_registered($user, $chan) or return;
+
+ my $cn = $chan->{CHAN};
+
+ my ($candoNick, $override) = can_do($chan, 'ACCLIST', $user, { OVERRIDE_MSG => "WHY $cn @tnicks" });
+ return unless $candoNick;
+
+ my @reply;
+ foreach my $tnick (@tnicks) {
+ my $tuser = { NICK => $tnick };
+ unless(get_user_id($tuser)) {
+ push @reply, "\002$tnick\002: No such user.";
+ next;
+ }
+
+ my $has;
+ if(is_online($tnick)) {
+ $has = 'has';
+ } else {
+ $has = 'had';
+ }
+
+ my $n;
+ $get_all_acc->execute(get_user_id($tuser), $cn);
+ while(my ($rnick, $acc) = $get_all_acc->fetchrow_array) {
+ $n++;
+ push @reply, "\002$tnick\002 $has $plevels[$acc+$plzero] access to \002$cn\002 due to identification to the nick \002$rnick\002.";
+ }
+ $get_all_acc->finish();
+
+ unless($n) {
+ push @reply, "\002$tnick\002 has no access to \002$cn\002.";
+ }
+ }
+ notice($user, @reply);
+}
+
+sub cs_setmodes($$$@) {
+ my ($user, $cmd, $chan, @args) = @_;
+ no warnings 'void';
+ my $agent = $user->{AGENT} or $csnick;
+ my $src = get_user_nick($user);
+ my $cn = $chan->{CHAN};
+ my $self;
+
+ if (cr_chk_flag($chan, CRF_FREEZE())) {
+ notice($user, "\002$cn\002 is frozen and access suspended.");
+ return;
+ }
+
+ if(scalar(@args) == 0) {
+ @args = ($src);
+ $self = 1;
+ } elsif($args[0] =~ /^#/) {
+ foreach my $chn ($cn, @args) {
+ next unless $chn =~ /^#/;
+ no warnings 'prototype'; # we call ourselves
+ cs_setmodes($user, $cmd, { CHAN => $chn });
+ }
+ return;
+ } elsif((scalar(@args) == 1) and (lc($args[0]) eq lc($src))) {
+ $self = 1;
+ }
+
+ # PROTECT is deprecated. remove it in a couple versions.
+ # It should be called ADMIN under PREFIX_AQ
+ my @mperms = ('VOICE', 'HALFOP', 'OP', 'ADMIN', 'OWNER');
+ my @l = ('v', 'h', 'o', 'a', 'q');
+ my ($level, @modes, $count);
+
+ if($cmd =~ /voice$/i) { $level = 0 }
+ elsif($cmd =~ /h(alf)?op$/i) { $level = 1 }
+ elsif($cmd =~ /op$/i) { $level = 2 }
+ elsif($cmd =~ /(protect|admin)$/i) { $level = 3 }
+ elsif($cmd =~ /owner$/i) { $level = 4 }
+ my $de = 1 if($cmd =~ s/^de//i);
+ #$cmd =~ s/^de//i;
+
+ my $acc = get_best_acc($user, $chan);
+
+ # XXX I'm not sure this is the best way to do it.
+ unless(
+ ($de and $self) or ($self and ($level + 2) <= $acc) or
+ can_do($chan, $mperms[$level], $user, { ACC => $acc, NOREPLY => 1, OVERRIDE_MSG => "$cmd $cn @args" }) )
+ {
+ notice($user, "$cn: $err_deny");
+ return;
+ }
+
+ my ($override, $check_override);
+
+ foreach my $target (@args) {
+ my ($tuser);
+
+ $tuser = ($self ? $user : { NICK => $target } );
+
+ unless(is_in_chan($tuser, $chan)) {
+ notice($user, "\002$target\002 is not in \002$cn\002.");
+ next;
+ }
+
+ my $top = get_op($tuser, $chan);
+
+ if($de) {
+ unless($top & (2**$level)) {
+ notice($user, "\002$target\002 has no $cmd in \002$cn\002.");
+ next;
+ }
+
+ if(!$override and get_best_acc($tuser, $chan) > $acc) {
+ unless($check_override) {
+ $override = adminserv::can_do($user, 'SUPER');
+ $check_override = 1;
+ }
+ if($check_override and !$override) {
+ notice($user, "\002$target\002 outranks you in \002$cn\002.");
+ next;
+ }
+ }
+ } else {
+ if($top & (2**$level)) {
+ if($self) {
+ notice($user, "You already have $cmd in \002$cn\002.");
+ } else {
+ notice($user, "\002$target\002 already has $cmd in \002$cn\002.");
+ }
+ next;
+ }
+ if (cr_chk_flag($chan, CRF_OPGUARD()) and
+ !can_keep_op($user, $chan, $tuser, $l[$level]))
+ {
+ notice($user, "$target may not hold ops in $cn because OpGuard is enabled. ".
+ "Please respect the founders wishes.");
+ next;
+ }
+ }
+
+ push @modes, [($de ? '-' : '+').$l[$level], $target];
+ $count++;
+
+ }
+
+ ircd::setmode2(agent($chan), $cn, @modes) if scalar @modes;
+ ircd::notice(agent($chan), '%'.$cn, "$src used ".($de ? "de$cmd" : $cmd).' '.join(' ', @args))
+ if !$self and (lc $user->{AGENT} eq lc $csnick) and cr_chk_flag($chan, CRF_VERBOSE);
+}
+
+sub cs_drop($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ chk_registered($user, $chan) or return;
+
+ unless(get_best_acc($user, $chan) == FOUNDER or adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ drop($chan);
+ notice($user, $cn.' has been dropped.');
+ services::ulog($csnick, LOG_INFO(), "dropped $cn", $user, $chan);
+
+ undef($enforcers{lc $cn});
+ botserv::bot_part_if_needed(undef(), $chan, "Channel dropped.");
+}
+#my ($bansref, $unbansref, $expires) = get_bans ($user, $chan, '', @targets, 1, $default_expiry);
+#my ($bansref, $unbansref, $expires) = get_bans ($user, $chan, '', @targets, 1, $expiry);
+sub get_bans($$$$;$$) {
+ my ($user, $chan, $type, $targetsref, $temp, $expiry) = (@_);
+ my (@bans, @unbans, @expires);
+ my ($nick, $override);
+
+ my @targets = @$targetsref;
+ my $cn = $chan->{CHAN};
+ my $src = get_user_nick($user);
+ my $srclevel = get_best_acc($user, $chan);
+
+ ($nick, $override) = can_do($chan, 'BAN', $user, { ACC => $srclevel });
+ return unless $nick;
+
+ my @errors = (
+ ["I'm sorry, $src, I'm afraid I can't do that."],
+ ["They are not in \002$cn\002."],
+ [$err_deny],
+ ["User not found"],
+ );
+
+ foreach my $target (@targets) {
+ my $tuser;
+
+ if ($target =~ /\+/ && $temp) {
+ $expiry = $target;
+ next;
+ }
+ if(ref($target)) {
+ $tuser = $target;
+ }
+ elsif($target =~ /\,/) {
+ push @targets, split(',', $target);
+ next;
+ }
+ elsif($target eq '') {
+ # Should never happen
+ # but it could, given the split above
+ next;
+ }
+ elsif($target =~ /^-/) {
+ $target =~ s/^\-//;
+ push @unbans, $target;
+ next;
+ }
+ elsif($target =~ /[!@]+/) {
+ $target = normalize_hostmask($target);
+ push @bans, $target;
+ if ($temp) {
+ push @expires, $expiry;
+ }
+ next;
+ }
+ elsif(valid_nick($target)) {
+ $tuser = { NICK => $target };
+ }
+ elsif($target = validate_ban($target)) {
+ push @bans, $target;
+ if ($temp) {
+ push @expires, $expiry;
+ }
+ next;
+ } else {
+ notice($user, "Not a valid ban target: $target");
+ next;
+ }
+
+ my $targetlevel = get_best_acc($tuser, $chan);
+
+ if(lc $target eq lc agent($chan) or adminserv::is_service($tuser)) {
+ push @{$errors[0]}, get_user_nick($tuser);
+ next;
+ }
+
+ unless(get_user_id($tuser)) {
+ push @{$errors[1]}, get_user_nick($tuser);
+ next;
+ }
+
+ if( $srclevel <= $targetlevel and not ($override && check_override($user, 'BAN', "BAN $cn $target")) ) {
+ push @{$errors[2]}, $target;
+ next;
+ }
+
+ push @bans, make_banmask($chan, $tuser, $type);
+ if ($temp) {
+ push @expires, $expiry;
+ }
+ }
+
+ if (!is_registered($chan)) {
+ notice ($user,
+ "$cn is not registered"
+ );
+ return;
+ }
+
+ foreach my $errlist (@errors) {
+ if(@$errlist > 1) {
+ my $msg = shift @$errlist;
+
+ foreach my $e (@$errlist) { $e = "\002$e\002" }
+
+ notice($user,
+ "Cannot ban ".
+ enum("or", @$errlist).
+ ": $msg"
+ );
+ }
+ }
+
+ return (\@bans, \@unbans, \@expires, $chan);
+}
+
+sub cs_tempban($$) {
+ my ($user, $args) = @_;
+ my ( $expiry, $cn, $chan );
+
+ my @args = split(/ /, $args);
+ my $length = @args;
+
+ for (my $i = 0; $i < $length; $i++) {
+ if ($args[$i] =~ /\#/) {
+ $cn = $args[$i];
+ $chan = { CHAN => $cn };
+ splice (@args, $i, 1);
+ }
+ }
+
+ if ($chan eq '') {
+ notice ($user, "No channel given. The channel name \002must\002 include the # character.");
+ return;
+ }
+
+ if ($args[-1] =~ /\+/) { #expire time is last arguement
+ $expiry = pop @args;
+ $expiry = parse_time($expiry);
+ } else { #expire time is somewhere else (if given), get default expiry for now.
+ $get_bantime->execute($cn);
+ ($expiry) = $get_bantime->fetchrow_array();
+ $get_bantime->finish();
+ }
+
+ my @targets;
+
+ foreach my $arg (@args) {
+ if ($arg =~ /\,/) {
+ push @targets, split(/\,/, $arg);
+ next;
+ } else {
+ push @targets, $arg;
+ }
+ }
+
+ my $src = get_user_nick($user);
+
+ my ($bansref, $unbansref, $expires, $chan) = get_bans ($user, $chan, '', \@targets, 1, $expiry);
+
+ if (!$bansref && !$unbansref) {
+ return;
+ }
+
+ my (@bans, @unbans) = (@$bansref, @$unbansref);
+
+ tempban ($chan, $bansref, $expires);
+
+ ircd::notice(agent($chan), $cn, "$src used TEMPBAN ".join(' ', @bans))
+ if (lc $user->{AGENT} eq lc $csnick) and (cr_chk_flag($chan, CRF_VERBOSE) and scalar(@bans));
+ cs_unban($user, $chan, @unbans) if scalar(@unbans);
+}
+
+sub cs_kick($$$;$$) {
+ my ($user, $chan, $target, $ban, $reason) = @_;
+
+ my $cmd = ($ban ? 'KICKBAN' : 'KICK');
+ my $perm = ($ban ? 'BAN' : 'KICK');
+
+ if(ref($chan) ne 'HASH' || !defined($chan->{CHAN})) {
+ notice($user, "Invalid $cmd command, no channel specified");
+ return;
+ }
+
+ my $srclevel = get_best_acc($user, $chan);
+
+ my ($nick, $override) = can_do($chan, ($ban ? 'BAN' : 'KICK'), $user, { ACC => $srclevel });
+ return unless $nick;
+
+ my $src = get_user_nick($user);
+ my $cn = $chan->{CHAN};
+
+ $reason = "Requested by $src".($reason?": $reason":'');
+
+ my @errors = (
+ ["I'm sorry, $src, I'm afraid I can't do that."],
+ ["They are not in \002$cn\002."],
+ [$err_deny],
+ ["User not found"],
+ );
+ my @notinchan = ();
+ my $peace = ({modes::splitmodes(get_modelock($chan))}->{Q}->[0] eq '+');
+
+ my @targets = split(/\,/, $target);
+ foreach $target (@targets) {
+ my $tuser = { NICK => $target };
+ my $targetlevel = get_best_acc($tuser, $chan);
+
+ if(lc $target eq lc agent($chan) or adminserv::is_service($tuser)) {
+ push @{$errors[0]}, $target;
+ next;
+ }
+
+ if(get_user_id($tuser)) {
+ unless(is_in_chan($tuser, $chan)) {
+ if ($ban) {
+ push @notinchan, $tuser;
+ } else {
+ push @{$errors[1]}, $target;
+ }
+ next;
+ }
+ } else {
+ push @{$errors[3]}, $target;
+ next;
+ }
+
+ if( ( ($peace and $targetlevel > 0) or ($srclevel <= $targetlevel) )
+ and not ($override && check_override($user, ($ban ? 'BAN' : 'KICK'), "$cmd $cn $target")) )
+ {
+ push @{$errors[2]}, $target;
+ next;
+ }
+
+ if($ban) {
+ kickban($chan, $tuser, undef, $reason, 1);
+ } else {
+ ircd::kick(agent($chan), $cn, $target, $reason) unless adminserv::is_service($user);
+ }
+ }
+ ircd::flushmodes() if($ban);
+
+ foreach my $errlist (@errors) {
+ if(@$errlist > 1) {
+ my $msg = shift @$errlist;
+
+ foreach my $e (@$errlist) { $e = "\002$e\002" }
+
+ notice($user,
+ "Cannot $cmd ".
+ enum("or", @$errlist).
+ ": $msg"
+ );
+ }
+ }
+ cs_ban($user, $chan, '', @notinchan) if ($ban and scalar (@notinchan));
+}
+
+sub cs_kickmask($$$;$$) {
+ my ($user, $chan, $mask, $ban, $reason) = @_;
+
+ my $srclevel = get_best_acc($user, $chan);
+ my $src = get_user_nick($user);
+ my $cn = $chan->{CHAN};
+
+ my $candoOpts = { ACC => $srclevel, OVERRIDE_MSG => 'KICK'.($ban ? 'BAN' : '')."MASK $cn $mask $reason" };
+ my ($nick, $override) = can_do($chan, ($ban ? 'BAN' : 'KICK'), $user, $candoOpts);
+ return unless $nick;
+
+
+ $reason = "Requested by $src".($reason?": $reason":'');
+
+ my $count = kickmask_noacc($chan, $mask, $reason, $ban);
+ notice($user, ($count ? "Users kicked from \002$cn\002: $count." : "No users in \002$cn\002 matched $mask."))
+}
+
+sub cs_ban($$$@) {
+ my ($user, $chan, $type, @targets) = @_;
+
+ my $src = get_user_nick ($user);
+
+ my $cn = $chan->{CHAN};
+
+ my ($bansref, $unbansref) = get_bans ($user, $chan, $type, \@targets);
+
+ if (!$bansref && !$unbansref) {
+ return;
+ }
+
+ my (@bans, @unbans) = (@$bansref, @$unbansref);
+
+ ircd::ban_list(agent($chan), $cn, +1, 'b', @bans) if (scalar(@bans));
+ ircd::notice(agent($chan), $cn, "$src used BAN ".join(' ', @bans))
+ if (lc $user->{AGENT} eq lc $csnick) and (cr_chk_flag($chan, CRF_VERBOSE) and scalar(@bans));
+ cs_unban($user, $chan, @unbans) if scalar(@unbans);
+}
+
+sub cs_invite($$@) {
+ my ($user, $chan, @targets) = @_;
+ my $src = get_user_nick($user);
+ my $cn = $chan->{CHAN};
+ my $srclevel = get_best_acc($user, $chan);
+
+ my @errors = (
+ ["They are not online."],
+ ["They are already in \002$cn\002."],
+ [$err_deny]
+ );
+
+ my @invited;
+ foreach my $target (@targets) {
+ my $tuser;
+ my $tnick;
+ if(ref($target)) {
+ $tuser = $target;
+ $tnick = get_user_nick($tuser);
+ } elsif(lc($src) eq lc($target)) {
+ $tuser = $user;
+ $tnick = $src;
+ } elsif($target =~ /\,/) {
+ push @targets, split(',', $target);
+ next;
+ } elsif($target eq '') {
+ # Should never happen
+ # but it could, given the split above
+ next;
+ } else {
+ $tuser = { NICK => $target };
+ $tnick = $target;
+ }
+
+ my $candoOpts = { ACC => $srclevel, NOREPLY => 1, OVERRIDE_MSG => "INVITE $cn $target" };
+ if(lc($src) eq lc($tnick)) {
+ unless(can_do($chan, 'InviteSelf', $user, $candoOpts)) {
+ push @{$errors[2]}, $tnick;
+ next;
+ }
+ }
+ else {
+ unless(can_do($chan, 'INVITE', $user, $candoOpts)) {
+ push @{$errors[2]}, $tnick;
+ next;
+ }
+
+ unless(nickserv::is_online($tnick)) {
+ push @{$errors[0]}, $tnick;
+ next;
+ }
+
+ # invite is annoying, so punish them mercilessly
+ return if flood_check($user, 2);
+ }
+
+ if(is_in_chan($tuser, $chan)) {
+ push @{$errors[1]}, $tnick;
+ next;
+ }
+
+ ircd::invite(agent($chan), $cn, $tnick); push @invited, $tnick;
+ ircd::notice(agent($chan), $tnick, "\002$src\002 has invited you to \002$cn\002.")
+ unless(lc($src) eq lc($tnick));
+ }
+
+ foreach my $errlist (@errors) {
+ if(@$errlist > 1) {
+ my $msg = shift @$errlist;
+
+ foreach my $e (@$errlist) { $e = "\002$e\002" }
+
+ notice($user,
+ "Cannot invite ".
+ enum("or", @$errlist).
+ ": $msg"
+ );
+ }
+ }
+
+ ircd::notice(agent($chan), $cn, "$src used INVITE ".join(' ', @invited))
+ if (lc $user->{AGENT} eq lc $csnick)and cr_chk_flag($chan, CRF_VERBOSE) and scalar(@invited);
+}
+
+sub cs_close($$$) {
+ my ($user, $chan, $reason, $type) = @_;
+ # $type is a flag, either CRF_CLOSE or CRF_DRONE
+ my $cn = $chan->{CHAN};
+ my $oper;
+
+ unless($oper = adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ my $rlength = length($reason);
+ if($rlength >= 350) {
+ notice($user, 'Close reason is too long by '. $rlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ if(is_registered($chan)) {
+ $drop_acc->execute($cn);
+ $drop_lvl->execute($cn);
+ $del_close->execute($cn);
+ $drop_akick->execute($cn);
+ $drop_welcome->execute($cn);
+ $drop_chantext->execute($cn);
+ $drop_nicktext->execute($cn); # Leftover channel auths
+
+ $set_founder->execute($oper, $cn);
+ }
+ else {
+ $register->execute($cn, $reason, $oper);
+ }
+ $set_modelock->execute('+rsnt', $cn);
+ do_modelock($chan);
+ set_acc($oper, undef, $chan, FOUNDER);
+
+ $set_close->execute($cn, $reason, $oper, $type);
+ cr_set_flag($chan, (CRF_FREEZE | CRF_CLOSE | CRF_DRONE), 0); #unset flags
+ cr_set_flag($chan, CRF_HOLD, 1); #set flags
+
+ my $src = get_user_nick($user);
+ my $time = gmtime2(time);
+ my $cmsg = "is closed [$src $time]: $reason";
+
+ if ($type == CRF_CLOSE) {
+ cr_set_flag($chan, CRF_CLOSE, 1); #set flags
+ clear_users($chan, "Channel $cmsg");
+ ircd::settopic(agent($chan), $cn, $src, time(), "Channel $cmsg")
+ }
+ elsif ($type == CRF_DRONE) {
+ cr_set_flag($chan, CRF_DRONE, 1); #set flags
+ chan_kill($chan, "$cn $cmsg");
+ }
+
+ notice($user, "The channel \002$cn\002 is now closed.");
+ services::ulog($csnick, LOG_INFO(), "closed $cn with reason: $reason", $user, $chan);
+}
+
+sub cs_clear_pre($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $srclevel = get_best_acc($user, $chan);
+
+ my ($cando, $override) = can_do($chan, 'CLEAR', $user, { ACC => $srclevel });
+ return 0 unless($cando);
+
+ $get_highrank->execute($cn);
+ my ($highrank_nick, $highrank_level) = $get_highrank->fetchrow_array();
+ $get_highrank->finish();
+
+ if($highrank_level > $srclevel && !$override) {
+ notice($user, "$highrank_nick outranks you in $cn (level: $levels[$highrank_level])");
+ return 0;
+ }
+
+ return 1;
+}
+
+sub cs_clear_users($$;$) {
+ my ($user, $chan, $reason) = @_;
+ my $src = get_user_nick($user);
+
+ cs_clear_pre($user, $chan) or return;
+
+ my $rlength = length($reason);
+ if($rlength >= 350) {
+ notice($user, 'Clear reason is too long by '. $rlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ clear_users($chan, "CLEAR USERS by \002$src\002".($reason?" reason: $reason":''));
+}
+
+sub cs_clear_modes($$;$) {
+ my ($user, $chan, $reason) = @_;
+ my $cn = $chan->{CHAN};
+ my $src = get_user_nick($user);
+
+ cs_clear_pre($user, $chan) or return;
+
+ my $rlength = length($reason);
+ if($rlength >= 350) {
+ notice($user, 'Clear reason is too long by '. $rlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ my $agent = agent($chan);
+ ircd::notice($agent, $cn, "CLEAR MODES by \002$src\002".($reason?" reason: $reason":''));
+
+ $get_chanmodes->execute($cn);
+ my ($curmodes) = $get_chanmodes->fetchrow_array;
+ my $ml = get_modelock($chan);
+
+ # This method may exceed the 12-mode limit
+ # But it seems to succeed anyway, even with more than 12.
+ my ($modes, $parms) = split(/ /, modes::merge(modes::invert($curmodes), $ml, 1). ' * *', 2);
+ # we split this separately,
+ # as otherwise it insists on taking the result of the split as a scalar quantity
+ ircd::setmode($agent, $cn, $modes, $parms);
+ do_modelock($chan);
+}
+
+sub cs_clear_ops($$;$) {
+ my ($user, $chan, $reason) = @_;
+ my $cn = $chan->{CHAN};
+ my $src = get_user_nick($user);
+
+ cs_clear_pre($user, $chan) or return;
+
+ my $rlength = length($reason);
+ if($rlength >= 350) {
+ notice($user, 'Clear reason is too long by '. $rlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ clear_ops($chan);
+
+ ircd::notice(agent($chan), $cn, "CLEAR OPS by \002$src\002".($reason?" reason: $reason":''));
+ return 1;
+}
+
+sub cs_clear_bans($$;$$) {
+ my ($user, $chan, $type, $reason) = @_;
+ my $cn = $chan->{CHAN};
+ my $src = get_user_nick($user);
+ $type = 0 unless defined $type;
+
+ cs_clear_pre($user, $chan) or return;
+
+ my $rlength = length($reason);
+ if($rlength >= 350) {
+ notice($user, 'Clear reason is too long by '. $rlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ clear_bans($chan, $type);
+
+ ircd::notice(agent($chan), $cn, "CLEAR BANS by \002$src\002".($reason?" reason: $reason":''));
+}
+
+sub cs_welcome_pre($$) {
+ my ($user, $chan) = @_;
+
+ return can_do($chan, 'WELCOME', $user);
+}
+
+sub cs_welcome_add($$$) {
+ my ($user, $chan, $msg) = @_;
+ my $src = get_best_acc($user, $chan, 1);
+ my $cn = $chan->{CHAN};
+
+ cs_welcome_pre($user, $chan) or return;
+
+ my $mlength = length($msg);
+ if($mlength >= 350) {
+ notice($user, 'Welcome Message is too long by '. $mlength-350 .' character(s). Maximum length is 350 characters.');
+ return;
+ }
+
+ $count_welcome->execute($cn);
+ my $count = $count_welcome->fetchrow_array;
+ if ($count >= 5) {
+ notice($user, 'There is a maximum of five (5) Channel Welcome Messages.');
+ return;
+ }
+
+ $add_welcome->execute($cn, ++$count, $src, $msg);
+
+ notice($user, "Welcome message number $count for \002$cn\002 set to:", " $msg");
+}
+
+sub cs_welcome_list($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ cs_welcome_pre($user, $chan) or return;
+
+ $list_welcome->execute($cn);
+
+ my @data;
+
+ while(my ($id, $time, $adder, $msg) = $list_welcome->fetchrow_array) {
+ push @data, ["$id.", $adder, gmtime2($time), $msg];
+ }
+ $list_welcome->finish();
+
+ notice($user, columnar {TITLE => "Welcome message list for \002$cn\002:", DOUBLE=>1,
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+}
+
+sub cs_welcome_del($$$) {
+ my ($user, $chan, $id) = @_;
+ my $cn = $chan->{CHAN};
+
+ cs_welcome_pre($user, $chan) or return;
+
+ if ($del_welcome->execute($cn, $id) == 1) {
+ notice($user, "Welcome Message \002$id\002 deleted from \002$cn\002");
+ $consolidate_welcome->execute($cn, $id);
+ }
+ else {
+ notice($user,
+ "Welcome Message number $id for \002$cn\002 does not exist.");
+ }
+}
+
+sub cs_alist($$;$) {
+ my ($user, $chan, $mask) = @_;
+ my $cn = $chan->{CHAN};
+
+ chk_registered($user, $chan) or return;
+
+ my $slevel = get_best_acc($user, $chan);
+
+ can_do($chan, 'ACCLIST', $user, { ACC => $slevel }) or return;
+
+ my @reply;
+
+ if($mask) {
+ my ($mnick, $mident, $mhost) = glob2sql(parse_mask($mask));
+ $mnick = '%' if($mnick eq '');
+ $mident = '%' if($mident eq '');
+ $mhost = '%' if($mhost eq '');
+
+ $get_acc_list2_mask->execute($mnick, $cn, $mnick, $mident, $mhost);
+ while(my ($nick, $adder, $level, $time, $last_used, $ident, $vhost) = $get_acc_list2_mask->fetchrow_array) {
+ push @reply, "*) $nick ($ident\@$vhost) Rank: ".$levels[$level] . ($adder ? ' Added by: '.$adder : '');
+ push @reply, ' '.($time ? 'Date/time added: '. gmtime2($time).' ' : '').
+ ($last_used ? 'Last used '.time_ago($last_used).' ago' : '') if ($time or $last_used);
+ }
+ $get_acc_list2_mask->finish();
+ } else {
+ $get_acc_list2->execute($cn);
+ while(my ($nick, $adder, $level, $time, $last_used, $ident, $vhost) = $get_acc_list2->fetchrow_array) {
+ push @reply, "*) $nick ($ident\@$vhost) Rank: ".$levels[$level] . ($adder ? ' Added by: '.$adder : '');
+ push @reply, ' '.($time ? 'Date/time added: '. gmtime2($time).' ' : '').
+ ($last_used ? 'Last used '.time_ago($last_used).' ago' : '') if ($time or $last_used);
+ }
+ $get_acc_list2->finish();
+ }
+
+ notice($user, "Access list for \002$cn\002:", @reply);
+
+ return;
+}
+
+sub cs_banlist($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+ can_do($chan, 'UnbanSelf', $user, { NOREPLY => 1 }) or can_do($chan, 'BAN', $user) or return;
+
+ my $i = 0; my @data;
+ $list_bans->execute($cn, 0);
+ while(my ($mask, $setter, $time) = $list_bans->fetchrow_array()) {
+ push @data, ["\002".++$i."\002", sql2glob($mask), $setter, ($time ? gmtime2($time) : '')];
+ }
+
+ notice($user, columnar {TITLE => "Ban list of \002$cn\002:", DOUBLE=>1,
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+}
+
+sub cs_unban($$@) {
+ my ($user, $chan, @parms) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $self;
+ $self = 1 if ( (scalar(@parms) == 1) and ( lc($parms[0]) eq lc(get_user_nick($user)) ) );
+ if ($parms[0] eq '*') {
+ cs_clear_bans($user, $chan);
+ return;
+ }
+ else {
+ can_do($chan, ($self ? 'UnbanSelf' : 'UNBAN'), $user) or return;
+ }
+
+ my (@userlist, @masklist);
+ foreach my $parm (@parms) {
+ if(valid_nick($parm)) {
+ my $tuser = ($self ? $user : { NICK => $parm });
+ unless(get_user_id($tuser)) {
+ notice($user, "No such user: \002$parm\002");
+ next;
+ }
+ push @userlist, $tuser;
+ } elsif($parm =~ /^[0-9\.,-]+$/) {
+ foreach my $num (makeSeqList($parm)) {
+ push @masklist, get_ban_num($chan, $num);
+ }
+ } else {
+ push @masklist, $parm;
+ }
+ }
+
+ if(scalar(@userlist)) {
+ unban_user($chan, @userlist);
+ notice($user, "All bans affecting " .
+ ( $self ? 'you' : enum( 'and', map(get_user_nick($_), @userlist) ) ) .
+ " on \002$cn\002 have been removed.");
+ }
+ if(scalar(@masklist)) {
+ ircd::ban_list(agent($chan), $cn, -1, 'b', @masklist);
+ notice($user, "The following bans have been removed: ".join(' ', @masklist))
+ if scalar(@masklist);
+ }
+}
+
+sub cs_updown($$@) {
+ my ($user, $cmd, @chans) = @_;
+ return cs_updown2($user, $cmd, { CHAN => shift @chans }, @chans)
+ if (defined($chans[1]) and $chans[1] !~ "^\#" and $chans[0] =~ "^\#");
+
+ @chans = get_user_chans($user)
+ unless (@chans);
+
+ if (uc($cmd) eq 'UP') {
+ foreach my $cn (@chans) {
+ next unless ($cn =~ /^\#/);
+ my $chan = { CHAN => $cn };
+ next if cr_chk_flag($chan, (CRF_DRONE | CRF_CLOSE | CRF_FREEZE), 1);
+ chanserv::set_modes($user, $chan, chanserv::get_best_acc($user, $chan));
+ }
+ }
+ elsif (uc($cmd) eq 'DOWN') {
+ foreach my $cn (@chans) {
+ next unless ($cn =~ /^\#/);
+ chanserv::unset_modes($user, { CHAN => $cn });
+ }
+ }
+}
+
+sub cs_updown2($$$@) {
+ my ($user, $cmd, $chan, @targets) = @_;
+ no warnings 'void';
+ my $agent = $user->{AGENT} or $csnick;
+ my $cn = $chan->{CHAN};
+
+ return unless chk_registered($user, $chan);
+ if (cr_chk_flag($chan, CRF_FREEZE())) {
+ notice($user, "\002$cn\002 is frozen and access suspended.");
+ return;
+ }
+
+ my $acc = get_best_acc($user, $chan);
+ return unless(can_do($chan, 'UPDOWN', $user, { ACC => $acc }));
+
+ my $updown = ((uc($cmd) eq 'UP') ? 1 : 0);
+
+ my ($override, $check_override);
+ my (@list, $count);
+ foreach my $target (@targets) {
+
+ my $tuser = { NICK => $target };
+
+ unless(is_in_chan($tuser, $chan)) {
+ notice($user, "\002$target\002 is not in \002$cn\002.");
+ next;
+ }
+
+ if($updown) {
+ push @list, $target;
+ chanserv::set_modes($tuser, $chan, chanserv::get_best_acc($tuser, $chan));
+ }
+ else {
+ my $top = get_op($tuser, $chan);
+ unless($top) {
+ notice($user, "\002$target\002 is already deopped in \002$cn\002.");
+ next;
+ }
+
+ if(!$override and get_best_acc($tuser, $chan) > $acc) {
+ unless($check_override) {
+ $override = adminserv::can_do($user, 'SUPER');
+ $check_override = 1;
+ }
+ if($check_override and !$override) {
+ notice($user, "\002$target\002 outranks you in \002$cn\002.");
+ next;
+ }
+ }
+ push @list, $target;
+ chanserv::unset_modes($tuser, { CHAN => $cn });
+ }
+ $count++;
+ }
+
+ my $src = get_user_nick($user);
+ ircd::notice(agent($chan), '%'.$cn, "$src used $cmd ".join(' ', @list))
+ if (lc $user->{AGENT} eq lc $csnick) and cr_chk_flag($chan, CRF_VERBOSE);
+}
+
+sub cs_getkey($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ can_do($chan, 'GETKEY', $user) or return;
+
+ $get_chanmodes->execute($cn);
+ my $modes = $get_chanmodes->fetchrow_array; $get_chanmodes->finish();
+
+ if(my $key = modes::get_key($modes)) {
+ notice($user, "Channel key for \002$cn\002: $key");
+ }
+ else {
+ notice($user, "\002$cn\002 has no channel key.");
+ }
+}
+
+sub cs_auth($$$@) {
+ my ($user, $chan, $cmd, @args) = @_;
+ my $cn = $chan->{CHAN};
+ $cmd = lc $cmd;
+
+ return unless chk_registered($user, $chan);
+ return unless can_do($chan, 'AccChange', $user);
+ my $userlevel = get_best_acc($user, $chan);
+ if($cmd eq 'list') {
+ my @data;
+ $list_auth_chan->execute($cn);
+ while(my ($nick, $data) = $list_auth_chan->fetchrow_array()) {
+ my ($adder, $old, $level, $time) = split(/:/, $data);
+ push @data, ["\002$nick\002", $levels[$level], $adder, gmtime2($time)];
+ }
+ if ($list_auth_chan->rows()) {
+ notice($user, columnar {TITLE => "Pending authorizations for \002$cn\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+ }
+ else {
+ notice($user, "There are no pending authorizations for \002$cn\002");
+ }
+ $list_auth_chan->finish();
+ }
+ elsif($cmd eq 'remove' or $cmd eq 'delete' or $cmd eq 'del') {
+ my ($nick, $adder, $old, $level, $time);
+ my $parm = shift @args;
+ if(misc::isint($parm) and ($nick, $adder, $old, $level, $time) = get_auth_num($cn, $parm))
+ {
+ }
+ elsif (($adder, $old, $level, $time) = get_auth_nick($cn, $parm))
+ {
+ $nick = $parm;
+ }
+ unless ($nick) {
+ # This should normally be an 'else' as the elsif above should prove false
+ # For some reason, it doesn't work. the unless ($nick) fixes it.
+ # It only doesn't work for numbered entries
+ notice($user, "There is no entry for \002$parm\002 in \002$cn\002's AUTH list");
+ return;
+ }
+ $nickserv::del_auth->execute($nick, $cn); $nickserv::del_auth->finish();
+ my $log_str = "deleted AUTH entry $cn $nick $levels[$level]";
+ my $src = get_user_nick($user);
+ notice($user, "You have $log_str");
+ ircd::notice(agent($chan), '%'.$cn, "has \002$src\002 has $log_str")
+ if cr_chk_flag($chan, CRF_VERBOSE);
+ services::ulog($chanserv::csnick, LOG_INFO(), "has $log_str", $user, $chan);
+ }
+ else {
+ notice($user, "Unknown AUTH command \002$cmd\002");
+ }
+}
+
+sub cs_mode($$$@) {
+ my ($user, $chan, $modes_in, @parms_in) = @_;
+ can_do($chan, 'MODE', $user) or return undef;
+ ($modes_in, @parms_in) = validate_chmodes($modes_in, @parms_in);
+
+ my %permhash = (
+ 'q' => 'OWNER',
+ 'a' => 'ADMIN',
+ 'o' => 'OP',
+ 'h' => 'HALFOP',
+ 'v' => 'VOICE',
+ );
+ my $sign = '+'; my $cn = $chan->{CHAN};
+ my ($modes_out, @parms_out, @bans);
+ foreach my $mode (split(//, $modes_in)) {
+ $sign = $mode if $mode =~ /[+-]/;
+ if ($permhash{$mode}) {
+ my $parm = shift @parms_in;
+ cs_setmodes($user, ($sign eq '-' ? 'de' : '').$permhash{$mode}, $chan, $parm);
+ }
+ elsif ($mode eq 'b') {
+ my $parm = shift @parms_in;
+ if($sign eq '-') {
+ $parm = '-'.$parm;
+ }
+ push @bans, $parm;
+ }
+ elsif($mode =~ /[eIlLkjf]/) {
+ $modes_out .= $mode;
+ push @parms_out, shift @parms_in;
+ } else {
+ $modes_out .= $mode;
+ }
+ }
+
+ if(scalar(@bans)) {
+ cs_ban($user, $chan, undef, @bans);
+ }
+ return if $modes_out =~ /^[+-]*$/;
+ ircd::setmode(agent($chan), $chan->{CHAN}, $modes_out, join(' ', @parms_out));
+ do_modelock($chan, $modes_out.' '.join(' ', @parms_out));
+
+ $modes_out =~ s/^[+-]*([+-].*)$/$1/;
+ ircd::notice(agent($chan), '%'.$cn, get_user_nick($user).' used MODE '.join(' ', $modes_out, @parms_out))
+ if (lc $user->{AGENT} eq lc $csnick) and cr_chk_flag($chan, CRF_VERBOSE);
+}
+
+sub cs_copy($$@) {
+ my ($user, $chan1, @args) = @_;
+ my $cn1 = $chan1->{CHAN};
+ my $cn2;
+ my $type;
+ if($args[0] =~ /^#/) {
+ $cn2 = shift @args;
+ $type = 'all';
+ }
+ if($args[0] =~ /(?:acc(?:ess)?|akick|levels|all)/i) {
+ $type = shift @args;
+ $cn2 = shift @args unless $cn2;
+ }
+ my $rank;
+ if($type =~ /^acc(?:ess)?/i) {
+ if($cn2 =~ /^#/) {
+ $rank = shift @args;
+ } else {
+ $rank = $cn2;
+ $cn2 = shift @args;
+ }
+ }
+ unless(defined $cn2 and defined $type) {
+ notice($user, 'Unknown COPY command', 'Syntax: COPY #chan1 [type] #chan2');
+ }
+ my $chan2 = { CHAN => $cn2 };
+ if(lc($cn1) eq lc($cn2)) {
+ notice($user, "You cannot copy a channel onto itself.");
+ }
+ unless(is_registered($chan1)) {
+ notice($user, "Source channel \002$cn1\002 must be registered.");
+ return;
+ }
+ can_do($chan1, 'COPY', $user) or return undef;
+ if(lc $type eq 'all') {
+ if(is_registered($chan2)) {
+ notice($user, "When copying all channel details, destination channel cannot be registered.");
+ return;
+ } elsif(!(get_op($user, $chan2) & ($opmodes{o} | $opmodes{a} | $opmodes{q}))) {
+ # This would be preferred to be a 'opmode_mask' or something
+ # However that might be misleading due to hop not being enough to register
+ notice($user, "You must have channel operator status to register \002$cn2\002.");
+ return;
+ } else {
+ cs_copy_chan_all($user, $chan1, $chan2);
+ return;
+ }
+ } else {
+ unless(is_registered($chan2)) {
+ notice($user, "When copying channel lists, destination channel must be registered.");
+ return;
+ }
+ can_do($chan2, 'COPY', $user) or return undef;
+ }
+ if(lc $type eq 'akick') {
+ cs_copy_chan_akick($user, $chan1, $chan2);
+ } elsif(lc $type eq 'levels') {
+ cs_copy_chan_levels($user, $chan1, $chan2);
+ } elsif($type =~ /^acc(?:ess)?/i) {
+ cs_copy_chan_acc($user, $chan1, $chan2, xop_byname($rank));
+ }
+}
+
+sub cs_copy_chan_all($$$) {
+ my ($user, $chan1, $chan2) = @_;
+ cs_copy_chan_chanreg($user, $chan1, $chan2);
+ cs_copy_chan_levels($user, $chan1, $chan2);
+ cs_copy_chan_acc($user, $chan1, $chan2);
+ cs_copy_chan_akick($user, $chan1, $chan2);
+ return;
+}
+
+sub cs_copy_chan_chanreg($$$) {
+ my ($user, $chan1, $chan2) = @_;
+ my $cn1 = $chan1->{CHAN};
+ my $cn2 = $chan2->{CHAN};
+
+ copy_chan_chanreg($cn1, $cn2);
+ botserv::bot_join($chan2) unless (lc(agent($chan2)) eq lc($csnick) );
+ do_modelock($chan2);
+ notice($user, "Registration for \002$cn1\002 copied to \002$cn2\002");
+
+ my $log_str = "copied the channel registration for \002$cn1\002 to \002$cn2\002";
+ services::ulog($chanserv::csnick, LOG_INFO(), "$log_str", $user, $chan1);
+
+ my $src = get_user_nick($user);
+ ircd::notice(agent($chan1), '%'.$cn1, "\002$src\002 $log_str")
+ if cr_chk_flag($chan1, CRF_VERBOSE);
+ ircd::notice(agent($chan2), '%'.$cn2, "\002$src\002 $log_str")
+ if cr_chk_flag($chan2, CRF_VERBOSE);
+}
+
+sub cs_copy_chan_acc($$$;$) {
+ my ($user, $chan1, $chan2, $level) = @_;
+ my $cn1 = $chan1->{CHAN};
+ my $cn2 = $chan2->{CHAN};
+
+ copy_chan_acc($cn1, $cn2, $level);
+
+ unless(cr_chk_flag($chan2, CRF_NEVEROP)) {
+ $get_chan_users->execute($cn2); my @targets;
+ while (my ($nick, $uid) = $get_chan_users->fetchrow_array()) {
+ push @targets, $nick unless nr_chk_flag_user({ NICK => $nick, ID => $uid }, NRF_NEVEROP);
+ }
+ cs_updown2($user, 'UP', $chan2, @targets);
+ }
+
+ notice($user, "Access list for \002$cn1\002 ".
+ ($level ? "(rank: \002".$plevels[$level + $plzero]."\002) " : '').
+ "copied to \002$cn2\002");
+
+ my $log_str = "copied the channel access list for \002$cn1\002 ".
+ ($level ? "(rank: \002".$plevels[$level + $plzero]."\002) " : '').
+ "to \002$cn2\002";
+ services::ulog($chanserv::csnick, LOG_INFO(), "$log_str", $user, $chan1);
+
+ my $src = get_user_nick($user);
+ ircd::notice(agent($chan1), '%'.$cn1, "\002$src\002 $log_str")
+ if cr_chk_flag($chan1, CRF_VERBOSE);
+ ircd::notice(agent($chan2), '%'.$cn2, "\002$src\002 $log_str")
+ if cr_chk_flag($chan2, CRF_VERBOSE);
+}
+
+sub cs_copy_chan_levels($$$) {
+ my ($user, $chan1, $chan2) = @_;
+ my $cn1 = $chan1->{CHAN};
+ my $cn2 = $chan2->{CHAN};
+
+ copy_chan_levels($cn1, $cn2);
+ notice($user, "LEVELS for \002$cn1\002 copied to \002$cn2\002");
+
+ my $log_str = "copied the LEVELS list for \002$cn1\002 to \002$cn2\002";
+ services::ulog($chanserv::csnick, LOG_INFO(), "$log_str", $user, $chan1);
+
+ my $src = get_user_nick($user);
+ ircd::notice(agent($chan1), '%'.$cn1, "\002$src\002 $log_str")
+ if cr_chk_flag($chan1, CRF_VERBOSE);
+ ircd::notice(agent($chan2), '%'.$cn2, "\002$src\002 $log_str")
+ if cr_chk_flag($chan2, CRF_VERBOSE);
+}
+
+sub cs_copy_chan_akick($$$) {
+ my ($user, $chan1, $chan2) = @_;
+ my $cn1 = $chan1->{CHAN};
+ my $cn2 = $chan2->{CHAN};
+
+ copy_chan_akick($cn1, $cn2);
+ notice($user, "Channel AKick list for \002$cn1\002 copied to \002$cn2\002");
+
+ my $log_str = "copied the AKick list for \002$cn1\002 to \002$cn2\002";
+ services::ulog($chanserv::csnick, LOG_INFO(), "$log_str", $user, $chan1);
+
+ my $src = get_user_nick($user);
+ ircd::notice(agent($chan1), '%'.$cn1, "\002$src\002 $log_str")
+ if cr_chk_flag($chan1, CRF_VERBOSE);
+ ircd::notice(agent($chan2), '%'.$cn2, "\002$src\002 $log_str")
+ if cr_chk_flag($chan2, CRF_VERBOSE);
+}
+
+sub cs_mlock($$$@) {
+ my ($user, $chan, $cmd, @args) = @_;
+ my $cn = $chan->{CHAN};
+ # does this need its own privilege now?
+ can_do($chan, 'SET', $user) or return;
+ my $modes;
+ if(scalar(@args)) {
+ my ($modes_in, @parms_in) = validate_chmodes(shift @args, @args);
+ $modes = $modes_in.' '.join(' ', @parms_in);
+ @args = undef;
+ }
+
+ my $cur_modelock = get_modelock($chan);
+ if(lc $cmd eq 'add') {
+ $modes = modes::merge($cur_modelock, $modes, 1);
+ $modes = sanitize_mlockable($modes);
+ $set_modelock->execute($modes, $cn);
+ }
+ elsif(lc $cmd eq 'del') {
+ $modes =~ s/[+-]//g;
+ $modes = modes::add($cur_modelock, "-$modes", 1);
+ $set_modelock->execute($modes, $cn);
+ }
+ elsif(lc $cmd eq 'set') {
+ $modes = modes::merge($modes, "+r", 1);
+ $set_modelock->execute($modes, $cn);
+ }
+ elsif(lc $cmd eq 'reset') {
+ $set_modelock->execute(services_conf_default_channel_mlock, $cn);
+ } else {
+ notice($user, "Unknown MLOCK command \"$cmd\"");
+ return;
+ }
+
+ notice($user, "Mode lock for \002$cn\002 has been set to: \002$modes\002");
+ do_modelock($chan);
+
+=cut
+ notice($user, columnar {TITLE => "Ban list of \002$cn\002:", DOUBLE=>1,
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+=cut
+}
+
+use SrSv::MySQL::Stub {
+ getChanUsers => ['COLUMN', "SELECT user.nick FROM chanuser JOIN user ON (user.id=chanuser.nickid)
+ WHERE chanuser.chan=? AND chanuser.joined=1"]
+};
+
+sub cs_resync($@) {
+ my ($user, @cns) = @_;
+ foreach my $cn (@cns) {
+ my $chan = { CHAN => $cn };
+ next unless cs_clear_ops($user, $chan, 'Resync');
+ cs_updown2($user, 'up', $chan, getChanUsers($cn));
+ if(can_do($chan, 'AKickEnforce', $user, { OVERRIDE_MSG => "AKICK $cn ENFORCE", NOREPLY => 1 })) {
+ cs_akick_enforce($user, $chan);
+ }
+ }
+}
+
+sub cs_join($@) {
+ my ($user, @cns) = @_;
+ my @reply;
+ my @out_cns;
+ foreach my $cn (@cns) {
+ if($cn =~ /,/) {
+ push @cns, split(',', $cn);
+ }
+ elsif($cn eq '') {
+ next;
+ }
+ my $chan = { CHAN => $cn };
+ my $cando_opts = { NOREPLY => 1 };
+ if(check_akick($user, $chan, 1)) {
+ push @reply, "You are banned from $cn";
+ next;
+ } elsif(!can_do($chan, 'JOIN', $user, $cando_opts)) {
+ push @reply, "$cn is a private channel.";
+ next;
+ }
+ if(is_in_chan($user, $chan)) {
+ next;
+ }
+ if(can_do($chan, 'InviteSelf', $user, $cando_opts)) {
+ cs_invite($user, $chan, $user);
+ }
+ push @out_cns, $cn;
+
+ }
+ ircd::svsjoin(get_user_agent($user), get_user_nick($user), @out_cns) if scalar @out_cns;
+ notice($user, @reply) if scalar @reply;
+}
+
+sub cs_topic($$@) {
+ my ($user, $cn, @args) = @_;
+ my ($chan, $msg) = ($cn->{CHAN}, join(" ", @args));
+ can_do($cn, 'SETTOPIC', $user) or return undef;
+ ircd::settopic(agent($cn), $chan, get_user_nick($user), time, ($msg =~ /^none/i ? "" : $msg));
+}
+
+### MISCELLANEA ###
+
+# these are helpers and do NOT check if $cn1 or $cn2 is reg'd
+sub copy_chan_acc($$;$) {
+ my ($cn1, $cn2, $level) = @_;
+ if($level) {
+ $copy_acc_rank->execute($cn2, $cn1, $level);
+ $copy_acc_rank->finish();
+ } else {
+ $get_founder->execute($cn2);
+ my ($founder) = $get_founder->fetchrow_array;
+ $get_founder->finish();
+
+ $copy_acc->execute($cn2, $cn1, $founder);
+ $copy_acc->finish();
+ }
+}
+
+sub copy_chan_akick($$;$) {
+ my ($cn1, $cn2) = @_;
+ $copy_akick->execute($cn2, $cn1);
+ $copy_akick->finish();
+ copy_chan_acc($cn1, $cn2, -1);
+}
+
+sub copy_chan_levels($$) {
+ my ($cn1, $cn2) = @_;
+ $copy_levels->execute($cn2, $cn1);
+ $copy_levels->finish();
+}
+
+sub copy_chan_chanreg($$) {
+ my ($cn1, $cn2) = @_;
+ $get_founder->execute($cn1);
+ my ($founder) = $get_founder->fetchrow_array;
+ $get_founder->finish();
+ set_acc($founder, undef, { CHAN => $cn2 }, FOUNDER);
+ $copy_chanreg->execute($cn2, $cn1);
+ $copy_chanreg->finish();
+}
+
+sub do_welcome($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ $get_welcomes->execute($cn);
+ if($get_welcomes->rows) {
+ my @welcomes;
+ while(my ($msg) = $get_welcomes->fetchrow_array) {
+ push @welcomes, (cr_chk_flag($chan, CRF_WELCOMEINCHAN) ? '' : "[$cn] " ).$msg;
+ }
+ if(cr_chk_flag($chan, CRF_WELCOMEINCHAN)) {
+ ircd::privmsg(agent($chan), $cn, @welcomes);
+ } else {
+ notice($user, @welcomes);
+ }
+ }
+ $get_welcomes->finish();
+}
+
+sub do_greet($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ if(can_do($chan, 'GREET', $user)) {
+ my $src = get_user_nick($user);
+ $nickserv::get_greet->execute(get_user_id($user));
+ my ($greet) = $nickserv::get_greet->fetchrow_array();
+ $nickserv::get_greet->finish();
+ ircd::privmsg(agent($chan), $cn, "[\002$src\002] $greet") if $greet;
+ }
+}
+
+sub chk_registered($$) {
+ my ($user, $chan) = @_;
+
+ unless(is_registered($chan)) {
+ my $cn = $chan->{CHAN};
+
+ notice($user, "The channel \002$cn\002 is not registered.");
+ return 0;
+ }
+
+ return 1;
+}
+
+sub make_banmask($$;$) {
+ my ($chan, $tuser, $type) = @_;
+ my $nick = get_user_nick($tuser);
+
+ my ($ident, $vhost) = get_vhost($tuser);
+ no warnings 'misc';
+ my ($nick, $ident, $vhost) = make_hostmask(get_bantype($chan), $nick, $ident, $vhost);
+ if($type eq 'q') {
+ $type = '~q:';
+ } elsif($type eq 'n') {
+ $type = '~n:';
+ } else {
+ $type = '';
+ }
+ return $type."$nick!$ident\@$vhost";
+}
+
+sub kickban($$$$;$$) {
+ my ($chan, $user, $mask, $reason, $noflush) = @_;
+
+ my $cn = $chan->{CHAN};
+ my $nick;
+ $nick = get_user_nick($user) if ($user);
+
+ if (!$user && !$mask) {
+ return;
+ }
+
+ return 0 if $user && adminserv::is_service($user);
+
+ my $agent = agent($chan);
+
+ unless($mask) {
+ $mask = make_banmask($chan, $user);
+ }
+
+ enforcer_join($chan) if (get_user_count($chan) <= 1);
+ ircd::setmode($agent, $cn, '+b', $mask);
+
+ ircd::flushmodes() unless $noflush;
+ ircd::kick($agent, $cn, $nick, $reason) if ($nick);
+ return 1;
+}
+
+sub kickban_multi($$$) {
+ my ($chan, $users, $reason) = @_;
+ my $cn = $chan->{CHAN};
+ my $agent = agent($chan);
+
+ enforcer_join($chan);
+ ircd::setmode($agent, $cn, '+b', '*!*@*');
+ ircd::flushmodes();
+
+ foreach my $user (@$users) {
+ next if adminserv::is_ircop($user) or adminserv::is_svsop($user, adminserv::S_HELP());
+ ircd::kick($agent, $cn, get_user_nick($user), $reason);
+ }
+}
+
+sub clear_users($$) {
+ my ($chan, $reason) = @_;
+ my $cn = $chan->{CHAN};
+ my $agent = agent($chan);
+ my $i;
+
+ enforcer_join($chan);
+ ircd::setmode($agent, $cn, '+b', '*!*@*');
+ ircd::flushmodes();
+ $get_chan_users->execute($cn);
+ while(my ($nick, $uid) = $get_chan_users->fetchrow_array) {
+ my $user = { NICK => $nick, ID => $uid };
+ ircd::kick($agent, $cn, $nick, $reason)
+ unless adminserv::is_ircop($user) or adminserv::is_svsop($user, adminserv::S_HELP());
+ $i++;
+ }
+
+ return $i;
+}
+
+sub kickmask($$$$) {
+ my ($chan, $mask, $reason, $ban) = @_;
+ my $cn = $chan->{CHAN};
+ my $agent = agent($chan);
+
+ my ($nick, $ident, $host) = glob2sql(parse_mask($mask));
+ $nick = '%' if ($nick eq '');
+ $ident = '%' if ($ident eq '');
+ $host = '%' if ($host eq '');
+
+ if ($ban) {
+ my $banmask = $nick.'!'.$ident.'@'.$host;
+ $banmask =~ tr/%_/*?/;
+ ircd::setmode($agent, $cn, '+b', $banmask);
+ ircd::flushmodes();
+ }
+
+ my $i;
+ $get_chan_users_mask->execute($cn, $nick, $ident, $host, $host, $host);
+ while(my ($nick, $uid) = $get_chan_users_mask->fetchrow_array) {
+ my $user = { NICK => $nick, ID => $uid };
+ ircd::kick($agent, $cn, $nick, $reason)
+ unless adminserv::is_service($user);
+ $i++;
+ }
+ $get_chan_users_mask->finish();
+
+ return $i;
+}
+
+sub kickmask_noacc($$$$) {
+ my ($chan, $mask, $reason, $ban) = @_;
+ my $cn = $chan->{CHAN};
+ my $agent = agent($chan);
+
+ my ($nick, $ident, $host) = glob2sql(parse_mask($mask));
+ $nick = '%' if ($nick eq '');
+ $ident = '%' if ($ident eq '');
+ $host = '%' if ($host eq '');
+
+ if ($ban) {
+ my $banmask = $nick.'!'.$ident.'@'.$host;
+ $banmask =~ tr/%_/*?/;
+ ircd::setmode($agent, $cn, '+b', $banmask);
+ ircd::flushmodes();
+ }
+
+ my $i;
+ $get_chan_users_mask_noacc->execute($cn, $nick, $ident, $host, $host, $host);
+ while(my ($nick, $uid) = $get_chan_users_mask_noacc->fetchrow_array) {
+ my $user = { NICK => $nick, ID => $uid };
+ ircd::kick($agent, $cn, $nick, $reason)
+ unless adminserv::is_service($user);
+ $i++;
+ }
+ $get_chan_users_mask_noacc->finish();
+
+ return $i;
+}
+
+sub clear_ops($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+ my @modelist;
+ my $agent = agent($chan);
+
+ $get_chan_users->execute($cn);
+ while(my ($nick, $uid) = $get_chan_users->fetchrow_array) {
+ my $user = { NICK => $nick, ID => $uid };
+ my $opmodes = get_op($user, $chan);
+ for(my $i; $i < 5; $i++) {
+ if($opmodes & 2**$i) {
+ push @modelist, ['-'.$opmodes[$i], $nick];
+ }
+ }
+ }
+
+ ircd::setmode2($agent, $cn, @modelist);
+}
+
+sub clear_bans($;$) {
+ my ($chan, $type) = @_;
+ my $cn = $chan->{CHAN};
+ my @args = ();
+ my $agent = agent($chan);
+ $type = 0 unless defined $type;
+ my $mode = ($type == 128 ? 'e' : 'b');
+
+ my @banlist = ();
+ $get_all_bans->execute($cn, $type);
+ while(my ($mask) = $get_all_bans->fetchrow_array) {
+ $mask =~ tr/\%\_/\*\?/;
+ push @banlist, $mask;
+ }
+
+ ircd::ban_list($agent, $cn, -1, $mode, @banlist);
+ ircd::flushmodes();
+}
+
+sub unban_user($@) {
+ my ($chan, @userlist) = @_;
+ my $cn = $chan->{CHAN};
+ my $count;
+ if (defined(&ircd::unban_nick)) {
+ my @nicklist;
+ foreach my $tuser (@userlist) {
+ push @nicklist, get_user_nick($tuser);
+ }
+ ircd::unban_nick(agent($chan), $cn, @nicklist);
+ return scalar(@nicklist);
+ }
+
+ foreach my $tuser (@userlist) {
+ my $tuid;
+ unless($tuid = get_user_id($tuser)) {
+ next;
+ }
+
+ my (@bans);
+ # We don't handle extended bans. Yet.
+ $find_bans_chan_user->execute($cn, $tuid, 0);
+ while (my ($mask) = $find_bans_chan_user->fetchrow_array) {
+ $mask =~ tr/\%\_/\*\?/;
+ push @bans, $mask;
+ }
+ $find_bans_chan_user->finish();
+
+ ircd::ban_list(agent($chan), $cn, -1, 'b', @bans) if scalar(@bans);
+ $delete_bans_chan_user->execute($cn, $tuid, 0); $delete_bans_chan_user->finish();
+ $count++;
+ }
+ return $count;
+}
+
+sub chan_kill($$;$) {
+ my ($chan, $reason, $tusers) = @_;
+ my $cn = $chan->{CHAN};
+ my $agent = agent($chan);
+ my $i;
+
+ enforcer_join($chan);
+ if ($tusers) {
+ foreach my $tuser (@$tusers) {
+ $tuser->{ID} = $tuser->{__ID} if defined($tuser->{__ID}); # user_join_multi does this.
+ nickserv::kline_user($tuser, services_conf_chankilltime, $reason)
+ unless adminserv::is_ircop($tuser) or adminserv::is_svsop($tuser, adminserv::S_HELP());
+ $i++;
+ }
+ }
+ else {
+ $get_chan_users->execute($cn);
+ while(my ($nick, $uid) = $get_chan_users->fetchrow_array) {
+ my $tuser = { NICK => $nick, ID => $uid, AGENT => $agent };
+ nickserv::kline_user($tuser, services_conf_chankilltime, $reason)
+ unless adminserv::is_ircop($tuser) or adminserv::is_svsop($tuser, adminserv::S_HELP());
+ $i++;
+ }
+ }
+
+ return $i;
+}
+
+sub do_nick_akick($$;$) {
+ my ($tuser, $chan, $root) = @_;
+ my $cn = $chan->{CHAN};
+ unless(defined($root)) {
+ (undef, $root) = get_best_acc($tuser, $chan, 2);
+ }
+
+ $get_nick_akick->execute($cn, $root);
+ my ($reason) = $get_nick_akick->fetchrow_array(); $get_nick_akick->finish();
+
+ return 0 if adminserv::is_svsop($tuser, adminserv::S_HELP());
+ if(defined($reason) && $reason =~ /\|/) {
+ ($reason, undef) = split(/ ?\| ?/, $reason, 2);
+ }
+ kickban($chan, $tuser, undef, "User has been banned from ".$cn.($reason?": $reason":''));
+}
+
+sub check_akick($$;$) {
+ my ($user, $chan, $check_only) = @_;
+
+ if(adminserv::is_svsop($user, adminserv::S_HELP())) {
+ return 0;
+ }
+ my ($acc, $root) = get_best_acc($user, $chan, 2);
+ if ($acc == -1) {
+ do_nick_akick($user, $chan, $root) unless $check_only;
+ return 1;
+ }
+ my $cn = $chan->{CHAN};
+ my $uid = get_user_id($user);
+ unless($acc) {
+ $get_akick->execute($uid, $cn);
+ if(my @akick = $get_akick->fetchrow_array) {
+ akickban($cn, @akick) unless $check_only;
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub do_status($$;$) {
+ my ($user, $chan, $check_only) = @_;
+
+ return 0 if cr_chk_flag($chan, (CRF_CLOSE | CRF_DRONE));
+
+ my $nick = get_user_nick($user);
+
+ if(check_akick($user, $chan, $check_only)) {
+ return 0;
+ }
+ my ($acc, $root) = get_best_acc($user, $chan, 2);
+ my ($accnick, $override) = can_do($chan, 'JOIN', $user, { ACC => $acc, NOREPLY => 1 });
+ unless ($acc > 0 || $override) {
+ if (clones_exist ($user, $chan)) {
+ my $mask = make_banmask($chan, $user);
+ my $cn = $chan->{CHAN};
+
+ tempban($chan, [ $mask ], "+60s");
+
+ ircd::kick(agent($chan), $cn, $nick, "No clones allowed in this channel.") unless adminserv::is_service($user);
+ }
+ }
+
+ if(!$accnick && !$override) {
+ kickban($chan, $user, undef, 'This is a private channel.')
+ unless $check_only;
+ return 0;
+ }
+
+ if( !$check_only && is_registered($chan) &&
+ !cr_chk_flag($chan, (CRF_CLOSE | CRF_DRONE)) )
+ {
+ my $neverop = (is_neverop_user($user) || cr_chk_flag($chan, CRF_NEVEROP, 1));
+ my $no_deop = cr_chk_flag($chan, CRF_SPLITOPS, 0);
+ my $op_anyway = 0;
+ if($neverop && cr_chk_flag($chan, CRF_AUTOVOICE, 1) && $acc > 2) {
+ $acc = 2;
+ $no_deop = 0;
+ $op_anyway = 1;
+ }
+ set_modes($user, $chan, $acc,
+ # $acc == 3 is +h
+ # this probably needs to be configurable for ports
+ # also Unreal may [optionally] set +q on join.
+ $no_deop,
+ !$neverop || $op_anyway,
+ );
+ }
+
+ return 1;
+}
+
+sub akick_alluser($) {
+ my ($user) = @_;
+ my $uid = get_user_id($user);
+
+ $get_akick_alluser->execute($uid);
+ while(my @akick = $get_akick_alluser->fetchrow_array) {
+ akickban(@akick);
+ }
+}
+
+sub akick_allchan($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ $get_akick_allchan->execute($cn);
+ while(my @akick = $get_akick_allchan->fetchrow_array) {
+ akickban($cn, @akick);
+ }
+}
+
+sub akickban(@) {
+ my ($cn, $knick, $bnick, $ident, $host, $reason, $bident) = @_;
+
+ my $target = { NICK => $knick };
+ my $chan = { CHAN => $cn };
+ return 0 if adminserv::is_svsop($target, adminserv::S_HELP());
+
+ if($bident) {
+ ($bnick, $ident, $host) = make_hostmask(get_bantype($chan), $knick, $bident, $host);
+ } elsif($host =~ /^(\d{1,3}\.){3}\d{1,3}$/) {
+ ($bnick, $ident, $host) = make_hostmask(4, $knick, $bident, $host);
+ } else {
+ $bnick =~ tr/\%\_/\*\?/;
+ $ident =~ tr/\%\_/\*\?/;
+ $host =~ tr/\%\_/\*\?/;
+ }
+
+ if(defined($reason) && $reason =~ /\|/) {
+ ($reason, undef) = split(/ ?\| ?/, $reason, 2);
+ }
+
+ return kickban($chan, $target, "$bnick!$ident\@$host", "User has been banned from ".$cn.($reason?": $reason":''));
+}
+
+sub notice_all_nicks($$$) {
+ my ($user, $nick, $msg) = @_;
+ my $src = get_user_nick($user);
+
+ notice($user, $msg);
+ foreach my $u (get_nick_user_nicks $nick) {
+ notice({ NICK => $u, AGENT => $csnick }, $msg) unless lc $src eq lc $u;
+ }
+}
+
+sub xop_byname($) {
+ my ($name) = @_;
+ my $level;
+
+ if($name =~ /^uop$/i) { $level=1; }
+ elsif($name =~ /^vop$/i) { $level=2; }
+ elsif($name =~ /^hop$/i) { $level=3; }
+ elsif($name =~ /^aop$/i) { $level=4; }
+ elsif($name =~ /^sop$/i) { $level=5; }
+ elsif($name =~ /^co?f(ounder)?$/i) { $level=6; }
+ elsif($name =~ /^founder$/i) { $level=7; }
+ elsif($name =~ /^(any|all|user)/i) { $level=0; }
+ elsif($name =~ /^akick$/i) { $level=-1; }
+ elsif($name =~ /^(none|disabled?|nobody)$/i) { $level=8; }
+
+ return $level;
+}
+
+sub expire {
+ return if services_conf_noexpire;
+
+ $get_expired->execute(time() - (86400 * services_conf_chanexpire));
+ while(my ($cn, $founder) = $get_expired->fetchrow_array) {
+ drop({ CHAN => $cn });
+ wlog($csnick, LOG_INFO(), "\002$cn\002 has expired. Founder: $founder");
+ }
+}
+
+sub enforcer_join($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+ my $bot = agent($chan);
+
+ return if $enforcers{lc $cn};
+ $enforcers{lc $cn} = lc $bot;
+
+ botserv::bot_join($chan);
+
+ add_timer("CSEnforce $bot $cn", 60, __PACKAGE__, 'chanserv::enforcer_part');
+}
+
+sub enforcer_part($) {
+ my ($cookie) = @_;
+ my ($junk, $bot, $cn) = split(/ /, $cookie);
+
+ return unless $enforcers{lc $cn};
+ undef($enforcers{lc $cn});
+
+ botserv::bot_part_if_needed($bot, {CHAN => $cn}, 'Enforcer Leaving');
+}
+
+sub fix_private_join_before_id($) {
+ my ($user) = @_;
+
+ my @cns = get_recent_private_chans(get_user_id($user));
+ foreach my $cn (@cns) {
+ my $chan = { CHAN => $cn };
+ unban_user($chan, $user);
+ }
+
+ ircd::svsjoin($csnick, get_user_nick($user), @cns) if @cns;
+}
+
+### DATABASE UTILITY FUNCTIONS ###
+
+sub get_user_count($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ $get_user_count->execute($cn);
+
+ return $get_user_count->fetchrow_array;
+}
+
+sub get_lock($) {
+ my ($chan) = @_;
+
+ $chan = lc $chan;
+
+ $chanuser_table++;
+
+ if($cur_lock) {
+ if($cur_lock ne $chan) {
+ really_release_lock($chan);
+ $chanuser_table--;
+ die("Tried to get two locks at the same time: $cur_lock, $chan")
+ }
+ $cnt_lock++;
+ } else {
+ $cur_lock = $chan;
+ $get_lock->execute(sql_conf_mysql_db.".chan.$chan");
+ $get_lock->finish;
+ }
+}
+
+sub release_lock($) {
+ my ($chan) = @_;
+
+ $chan = lc $chan;
+
+ $chanuser_table--;
+
+ if($cur_lock and $cur_lock ne $chan) {
+ really_release_lock($cur_lock);
+
+ die("Tried to release the wrong lock");
+ }
+
+ if($cnt_lock) {
+ $cnt_lock--;
+ } else {
+ really_release_lock($chan);
+ }
+}
+
+sub really_release_lock($) {
+ my ($chan) = @_;
+
+ $cnt_lock = 0;
+ $release_lock->execute(sql_conf_mysql_db.".chan.$chan");
+ $release_lock->finish;
+ undef $cur_lock;
+}
+
+#sub is_free_lock($) {
+# $is_free_lock->execute($_[0]);
+# return $is_free_lock->fetchrow_array;
+#}
+
+sub get_modelock($) {
+ my ($chan) = @_;
+ my $cn;
+ if(ref($chan)) {
+ $cn = $chan->{CHAN}
+ } else {
+ $cn = $chan;
+ }
+
+ $get_modelock->execute($cn);
+ my ($ml) = $get_modelock->fetchrow_array;
+ $get_modelock->finish();
+ return $ml;
+}
+
+sub do_modelock($;$) {
+ my ($chan, $modes) = @_;
+ my $cn = $chan->{CHAN};
+
+ my $seq = $ircline;
+
+ $get_modelock_lock->execute; $get_modelock_lock->finish;
+
+ $get_chanmodes->execute($cn);
+ my ($omodes) = $get_chanmodes->fetchrow_array;
+ my $ml = get_modelock($chan);
+
+ $ml = do_modelock_fast($cn, $modes, $omodes, $ml);
+
+ $unlock_tables->execute; $unlock_tables->finish;
+
+ ircd::setmode(agent($chan), $cn, $ml) if($ml);
+}
+
+sub do_modelock_fast($$$$) {
+ my ($cn, $modes, $omodes, $ml) = @_;
+ my $nmodes = modes::add($omodes, $modes, 1);
+ $ml = modes::diff($nmodes, $ml, 1);
+ $set_chanmodes->execute(modes::add($nmodes, $ml, 1), $cn);
+
+ return $ml;
+}
+
+sub update_modes($$) {
+ my ($cn, $modes) = @_;
+
+ $get_update_modes_lock->execute; $get_update_modes_lock->finish;
+ $get_chanmodes->execute($cn);
+ my ($omodes) = $get_chanmodes->fetchrow_array;
+
+ $set_chanmodes->execute(modes::add($omodes, $modes, 1), $cn);
+ $unlock_tables->execute; $unlock_tables->finish;
+}
+
+sub is_level($) {
+ my ($perm) = @_;
+
+ $is_level->execute($perm);
+
+ return $is_level->fetchrow_array;
+}
+
+sub is_neverop($) {
+ return nr_chk_flag($_[0], NRF_NEVEROP(), 1);
+}
+
+sub is_neverop_user($) {
+ return nr_chk_flag_user($_[0], NRF_NEVEROP(), 1);
+}
+
+sub is_in_chan($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+ my $uid = get_user_id($user);
+
+ $is_in_chan->execute($uid, $cn);
+ if($is_in_chan->fetchrow_array) {
+ return 1;
+ }
+
+ return 0;
+}
+
+sub is_registered($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ $is_registered->execute($cn);
+ if($is_registered->fetchrow_array) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub get_user_chans($) {
+ my ($user) = @_;
+ my $uid = get_user_id($user);
+ my @chans;
+
+ $get_user_chans->execute($uid, $ircline, $ircline+1000);
+ while(my ($chan) = $get_user_chans->fetchrow_array) {
+ push @chans, $chan;
+ }
+
+ return (@chans);
+}
+
+sub get_user_chans_recent($) {
+ my ($user) = @_;
+ my $uid = get_user_id($user);
+ my (@curchans, @oldchans);
+
+ $get_user_chans_recent->execute($uid);
+ while(my ($cn, $joined, $op) = $get_user_chans_recent->fetchrow_array) {
+ if ($joined) {
+ push @curchans, make_op_prefix($op).$cn;
+ }
+ else {
+ push @oldchans, $cn;
+ }
+ }
+
+ return (\@curchans, \@oldchans);
+}
+
+my ($prefixes, $modes);
+sub make_op_prefix($) {
+ my ($op) = @_;
+ return unless $op;
+
+ unless(defined($prefixes) and defined($modes)) {
+ $IRCd_capabilities{PREFIX} =~ /^\((\S+)\)(\S+)$/;
+ ($modes, $prefixes) = ($1, $2);
+ $modes = reverse $modes;
+ $prefixes = reverse $prefixes;
+ }
+
+ my $op_prefix = '';
+ for(my $i = 0; $i < length($prefixes); $i++) {
+ $op_prefix = substr($prefixes, $i, 1).$op_prefix if ($op & (2**$i));
+ }
+ return $op_prefix;
+}
+
+sub get_op($$) {
+ my ($user, $chan) = @_;
+ my $cn = $chan->{CHAN};
+ my $uid = get_user_id($user);
+
+ $get_op->execute($uid, $cn);
+ my ($op) = $get_op->fetchrow_array;
+
+ return $op;
+}
+
+sub get_best_acc($$;$) {
+ my ($user, $chan, $retnick) = @_;
+ my $uid = get_user_id($user);
+ my $cn = $chan->{CHAN};
+
+ $get_best_acc->execute($uid, $cn);
+ my ($bnick, $best) = $get_best_acc->fetchrow_array;
+ $get_best_acc->finish();
+
+ if($retnick == 2) {
+ return ($best, $bnick);
+ } elsif($retnick == 1) {
+ return $bnick;
+ } else {
+ return $best;
+ }
+}
+
+sub get_acc($$) {
+ my ($nick, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ return undef
+ if cr_chk_flag($chan, (CRF_DRONE | CRF_CLOSE | CRF_FREEZE), 1);
+
+ $get_acc->execute($cn, $nick);
+ my ($acc) = $get_acc->fetchrow_array;
+
+ return $acc;
+}
+
+sub set_acc($$$$) {
+ my ($nick, $user, $chan, $level) = @_;
+ my $cn = $chan->{CHAN};
+ my $adder;
+ $adder = get_best_acc($user, $chan, 1) if $user;
+
+ $set_acc1->execute($cn, $level, $nick);
+ $set_acc2->execute($level, $adder, $cn, $nick);
+
+ if ( ( $level > 0 and !is_neverop($nick) and !cr_chk_flag($chan, CRF_NEVEROP) )
+ or $level < 0)
+ {
+ set_modes_allnick($nick, $chan, $level);
+ }
+}
+
+sub del_acc($$) {
+ my ($nick, $chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ $del_acc->execute($cn, $nick);
+
+ foreach my $user (get_nick_users $nick) {
+ set_modes($user, $chan, 0, 1) if is_in_chan($user, $chan);
+ }
+}
+
+sub get_auth_nick($$) {
+ my ($cn, $nick) = @_;
+
+ $get_auth_nick->execute($cn, $nick);
+ my ($data) = $get_auth_nick->fetchrow_array();
+ $get_auth_nick->finish();
+
+ return split(/:/, $data);
+}
+sub get_auth_num($$) {
+ my ($cn, $num) = @_;
+
+ $get_auth_num->execute($cn, $num - 1);
+ my ($nick, $data) = $get_auth_num->fetchrow_array();
+ $get_auth_num->finish();
+
+ return ($nick, split(/:/, $data));
+}
+sub find_auth($$) {
+ my ($cn, $nick) = @_;
+
+ $find_auth->execute($cn, $nick);
+ my ($ret) = $find_auth->fetchrow_array();
+ $find_auth->finish();
+
+ return $ret;
+}
+
+# Only call this if you've checked the user for NEVEROP already.
+sub set_modes_allchan($;$) {
+ my ($user, $neverop) = @_;
+ my $uid = get_user_id($user);
+
+ $get_user_chans->execute($uid, $ircline, $ircline+1000);
+ while(my ($cn) = $get_user_chans->fetchrow_array) {
+ my $chan = { CHAN => $cn };
+ my $acc = get_best_acc($user, $chan);
+ if($acc > 0) {
+ set_modes($user, $chan, $acc) unless ($neverop or cr_chk_flag($chan, CRF_NEVEROP));
+ } elsif($acc < 0) {
+ do_nick_akick($user, $chan);
+ }
+ }
+}
+
+# Only call this if you've checked for NEVEROP already.
+sub set_modes_allnick($$$) {
+ my ($nick, $chan, $level) = @_;
+ my $cn = $chan->{CHAN};
+
+ $get_using_nick_chans->execute($nick, $cn);
+ while(my ($n) = $get_using_nick_chans->fetchrow_array) {
+ my $user = { NICK => $n };
+ my $l = get_best_acc($user, $chan);
+ if($l > 0) {
+ set_modes($user, $chan, $level, 1) if($level == $l);
+ } elsif($l < 0) {
+ do_nick_akick($user, $chan);
+ }
+ }
+}
+
+# If channel has OPGUARD, $doneg is true.
+sub set_modes($$$;$$) {
+ my ($user, $chan, $acc, $doneg, $dopos) = @_;
+ # can you say eww?
+ $dopos = 1 unless defined($dopos);
+ $doneg = 0 unless defined($doneg);
+ my $cn = $chan->{CHAN};
+
+
+ if ($acc < 0) {
+ # Do akick stuff here.
+ }
+
+ my $dst = ( $acc > 0 ? $ops[$acc] : 0 );
+ my $cur = get_op($user, $chan);
+ my ($pos, $neg);
+
+ if (cr_chk_flag($chan, CRF_FREEZE)) {
+ set_mode_mask($user, $chan, $cur, undef);
+ return;
+ }
+ if (($acc == 0) and cr_chk_flag($chan, CRF_AUTOVOICE)) {
+ set_mode_mask($user, $chan, $cur, 1);
+ return;
+ }
+
+ $pos = $dst ^ ($dst & $cur);
+ $neg = ($dst ^ $cur) & $cur if $doneg;
+
+ if($pos or $neg) {
+ set_mode_mask($user, $chan, ($doneg ? $neg : '-'), ($dopos ? $pos : '+'));
+ }
+
+ if($pos) {
+ set_lastop($cn);
+ set_lastused($cn, get_user_id($user));
+ }
+}
+
+sub unset_modes($$) {
+ my ($user, $chan) = @_;
+
+ my $mask = get_op($user, $chan);
+
+ set_mode_mask($user, $chan, $mask, 0);
+}
+
+sub set_mode_mask($$$$) {
+ my ($user, $chan, @masks) = @_;
+ my $nick = get_user_nick($user);
+ my $cn = $chan->{CHAN};
+ my (@args, $out);
+
+ for(my $sign; $sign < 2; $sign++) {
+ next if($masks[$sign] == 0);
+
+ $out .= '-' if $sign == 0;
+ $out .= '+' if $sign == 1;
+
+ for(my $i; $i < 5; $i++) {
+ my @l = ('v', 'h', 'o', 'a', 'q');
+
+ if($masks[$sign] & 2**$i) {
+ $out .= $l[$i];
+ push @args, $nick;
+ }
+ }
+ }
+
+ if(@args) {
+ ircd::setmode(agent($chan), $cn, $out, join(' ', @args));
+ }
+}
+
+sub get_level($$) {
+ my ($chan, $perm) = @_;
+ my $cn = $chan->{CHAN};
+
+ $get_level->execute($cn, $perm);
+ my ($level, $isnotnull) = $get_level->fetchrow_array;
+ $get_level->finish();
+
+ if (wantarray()) {
+ return ($level, $isnotnull);
+ }
+ else {
+ return $level;
+ }
+}
+
+sub check_override($$;$) {
+ my ($user, $perm, $logMsg) = @_;
+ $perm = uc $perm;
+
+ #{OVERRIDE::$perm} produces funny package problems, so wrap it in double-quotes.
+ if(exists($user->{"OVERRIDE::$perm"}) && (my $nick = $user->{"OVERRIDE::$perm"})) {
+ if(defined($nick)) {
+ if(services_conf_log_overrides && $logMsg) {
+ my $src = get_user_nick($user);
+ wlog($csnick, LOG_INFO(), "\002$src\002 used override $logMsg");
+ }
+ return (wantarray ? ($nick, 1) : $nick);
+ } else {
+ return;
+ }
+ }
+ foreach my $o (@override) {
+ my ($operRank, $permHashRef) = @$o;
+ if($permHashRef->{$perm} and my $nick = adminserv::can_do($user, $operRank)) {
+ $user->{"OVERRIDE::$perm"} = $nick;
+ if(services_conf_log_overrides && $logMsg) {
+ my $src = get_user_nick($user);
+ wlog($csnick, LOG_INFO(), "\002$src\002 used override $logMsg");
+ }
+ return (wantarray ? ($nick, 1) : $nick);
+ }
+ }
+ $user->{"OVERRIDE::$perm"} = undef;
+}
+
+sub can_do($$$;$) {
+ my ($chan, $perm, $user, $data) = @_;
+ $data = {} unless defined $data;
+ # $data is a hashref/struct
+ my $noreply = $data->{NOREPLY};
+ my $acc = $data->{ACC};
+ my $overrideMsg = $data->{OVERRIDE_MSG};
+
+ if(my $nick = __can_do($chan, $perm, $user, $acc)) {
+ # This is becoming increasingly complicated
+ # and checking if an override was used is becoming tricky.
+ # We had a case in cs_kick where an oper should be able to override +Q/$peace
+ # but cannot b/c they have regular access in that channel.
+ my $override;
+ if(defined($user)) {
+ (undef, $override) = check_override($user, $perm);
+ }
+ return (wantarray ? ($nick, $override) : $nick);
+ } elsif ( $user and adminserv::is_svsop($user, adminserv::S_HELP()) ) {
+ #set_lastused($cn, get_user_id($user));
+ my ($nick, $override) = check_override($user, $perm, $overrideMsg);
+ return (wantarray ? ($nick, $override) : $nick) if $override;
+ }
+ if($user and !$noreply) {
+ my $cn = $chan->{CHAN};
+ if (cr_chk_flag($chan, (CRF_CLOSE | CRF_DRONE))) {
+ notice($user, "\002$cn\002 is closed and cannot be used".
+ ((uc $perm eq 'INFO') ? ': '.get_close($chan) : '.'));
+ }
+ elsif(cr_chk_flag($chan, CRF_FREEZE)) {
+ notice($user, "\002$cn\002 is frozen and access suspended.");
+ }
+ else {
+ notice($user, "$cn: $err_deny");
+ }
+ }
+ return 0;
+}
+
+sub __can_do($$$;$) {
+ my ($chan, $perm, $user, $acc) = @_;
+ my $nick;
+ my $cn = $chan->{CHAN};
+ $perm = uc $perm;
+
+ my $level;
+ unless(exists($chan->{"PERM::$perm"})) {
+ $level = $chan->{"PERM::$perm"} = get_level($chan, $perm);
+ } else {
+ $level = $chan->{"PERM::$perm"};
+ }
+
+ unless(defined($acc)) {
+ unless (defined $user && ref($user) eq 'HASH') {
+ die "invalid __can_do call";
+ }
+ my $chanuser = $user->{lc $cn};
+ unless (defined($chanuser) && exists($chanuser->{ACC})) {
+ ($acc, $nick) = get_best_acc($user, $chan, 2);
+ ($chanuser->{ACC}, $chanuser->{ACCNICK}) = ($acc, $nick);
+ } else {
+ ($acc, $nick) = ($chanuser->{ACC}, $chanuser->{ACCNICK});
+ }
+ }
+ $nick = 1 unless $nick;
+
+ if($acc >= $level and !cr_chk_flag($chan, (CRF_CLOSE | CRF_FREEZE | CRF_DRONE))) {
+ set_lastused($cn, get_user_id($user)) if $user;
+ return (wantarray ? ($nick, 0) : $nick);
+ }
+
+ if(cr_chk_flag($chan, CRF_FREEZE) and ($perm eq 'JOIN')) {
+ return (wantarray ? ($nick, 0) : $nick);
+ }
+
+ return 0;
+}
+
+sub can_keep_op($$$$) {
+# This is a naïve implemenation using a loop.
+# If we ever do a more flexible version that further restricts how
+# LEVELS affect opguard, the loop will have to be unrolled.
+# --
+# Only call this if you've already checked opguard, as we do not check it here.
+# --
+# Remember, this isn't a permission check if someone is allowed to op someone [else],
+# rather this checks if the person being opped is allowed to keep/have it.
+ my ($user, $chan, $tuser, $opmode) = @_;
+ return 1 if $opmode eq 'v'; # why remove a voice?
+ my %permhash = (
+ 'q' => ['OWNER', 4],
+ 'a' => ['ADMIN', 3],
+ 'o' => ['OP', 2],
+ 'h' => ['HALFOP', 1],
+ 'v' => ['VOICE', 0]
+ );
+
+ my $self = (lc(get_user_nick($user)) eq lc(get_user_nick($tuser)));
+
+ #my ($level, $isnotnull) = get_level($chan, $permhash{$opmode}[1]);
+ my $level = get_level($chan, $permhash{$opmode}[0]);
+
+ foreach my $luser ($tuser, $user) {
+ # We check target first, as there seems no reason that
+ # someone who has access can't be opped by someone
+ # who technically doesn't.
+ return 1 if (adminserv::is_svsop($luser, adminserv::S_HELP()) and
+ check_override($luser, $permhash{$opmode}[0]));
+
+ my $acc = get_best_acc($luser, $chan);
+ return 1 if ($self and ($permhash{opmode}[2] + 2) <= $acc);
+
+ if($acc < $level) {
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+sub agent($) {
+ my ($chan) = @_;
+
+ return $chan->{AGENT} if($chan->{AGENT});
+
+ unless(initial_synced()) {
+ return $csnick;
+ }
+
+ $botserv::get_chan_bot->execute($chan->{CHAN});
+ my ($agent) = $botserv::get_chan_bot->fetchrow_array;
+
+ $agent = $csnick unless $agent;
+
+ return $chan->{AGENT} = $agent;
+}
+
+sub drop($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ undef($enforcers{lc $cn});
+ my $agent = agent($chan);
+ agent_part($agent, $cn, 'Channel dropped') unless (lc($agent) eq lc($csnick));
+ if (module::is_loaded('logserv')) {
+ eval { logserv::delchan(undef, $cn); }
+ }
+
+ $drop_acc->execute($cn);
+ $drop_lvl->execute($cn);
+ $del_close->execute($cn);
+ $drop_akick->execute($cn);
+ $drop_welcome->execute($cn);
+ $drop_chantext->execute($cn);
+ $drop_nicktext->execute($cn); # Leftover channel auths
+ $drop->execute($cn);
+ ircd::setmode($csnick, $cn, '-r');
+}
+
+sub drop_nick_chans($) {
+ my ($nick) = @_;
+
+ $delete_successors->execute($nick);
+
+ $get_nick_own_chans->execute($nick);
+ while(my ($cn) = $get_nick_own_chans->fetchrow_array) {
+ succeed_chan($cn, $nick);
+ }
+}
+
+sub succeed_chan($$) {
+ my ($cn, $nick) = @_;
+
+ $get_successor->execute($cn);
+ my ($suc) = $get_successor->fetchrow_array;
+
+ if($suc) {
+ $set_founder->execute($suc, $cn);
+ set_acc($suc, undef, {CHAN => $cn}, FOUNDER);
+ $del_successor->execute($cn);
+ } else {
+ drop({CHAN => $cn});
+ wlog($csnick, LOG_INFO(), "\002$cn\002 has been dropped due to expiry/drop of \002$nick\002");
+ }
+}
+
+sub get_close($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+ return undef unless cr_chk_flag($chan, CRF_CLOSE | CRF_DRONE);
+
+ $get_close->execute($cn);
+ my ($reason, $opnick, $time) = $get_close->fetchrow_array();
+ $get_close->finish();
+
+ $reason = "[$opnick ".gmtime2($time)."] - $reason";
+
+ return (wantarray ? ($reason, $opnick, $time) : $reason);
+}
+
+sub get_users_nochans(;$) {
+ my ($noid) = @_;
+ my @users;
+
+ if($noid) {
+ $get_users_nochans_noid->execute();
+ while (my ($usernick, $userid) = $get_users_nochans_noid->fetchrow_array()) {
+ push @users, { NICK => $usernick, ID => $userid };
+ }
+ $get_users_nochans_noid->finish();
+ }
+ else {
+ $get_users_nochans->execute();
+ while (my ($usernick, $userid) = $get_users_nochans->fetchrow_array()) {
+ push @users, { NICK => $usernick, ID => $userid };
+ }
+ $get_users_nochans->finish();
+ }
+
+ return @users;
+}
+
+sub get_bantype($) {
+ my ($chan) = @_;
+ my $cn = $chan->{CHAN};
+
+ unless (exists($chan->{BANTYPE})) {
+ $get_bantype->execute($cn);
+ ($chan->{BANTYPE}) = $get_bantype->fetchrow_array();
+ $get_bantype->finish();
+ }
+
+ return $chan->{BANTYPE};
+}
+
+sub memolog($$) {
+ my ($chan, $log) = @_;
+
+ my $level = get_level($chan, "MemoAccChange");
+ return if $level == 8; # 8 is 'disable'
+ $level = 1 if $level == 0;
+ memoserv::send_chan_memo($csnick, $chan, $log, $level);
+}
+
+sub get_ban_num($$) {
+ my ($chan, $num) = @_;
+ $get_ban_num->execute($chan->{CHAN}, 0, $num-1);
+ my ($mask) = $get_ban_num->fetchrow_array();
+ $get_ban_num->finish();
+ return sql2glob($mask);
+}
+
+### IRC EVENTS ###
+
+sub user_join($$) {
+# Due to special casing of '0' this wrapper should be used
+# by anyone handling a JOIN (not SJOIN, it's a JOIN) event.
+# This is an RFC1459 requirement.
+ my ($nick, $cn) = @_;
+ my $user = { NICK => $nick };
+ my $chan = { CHAN => $cn };
+
+ if ($cn == 0) {
+ # This should be treated as a number
+ # Just in case we ever got passed '000', not that Unreal does.
+ # In C, you could check that chan[0] != '#' && chan[0] == '0'
+ user_part_multi($user, [ get_user_chans($user) ], 'Left all channels');
+ }
+ else {
+ user_join_multi($chan, [$user]);
+ }
+}
+
+sub handle_sjoin($$$$$$$) {
+ my ($server, $cn, $ts, $chmodes, $chmodeparms, $userarray, $banarray, $exceptarray) = @_;
+ my $chan = { CHAN => $cn };
+
+ if(synced()) {
+ chan_mode($server, $cn, $chmodes, $chmodeparms) if $chmodes;
+ } else {
+ update_modes($cn, "$chmodes $chmodeparms") if $chmodes;
+ }
+ user_join_multi($chan, $userarray) if scalar @$userarray;
+
+ foreach my $ban (@$banarray) {
+ process_ban($cn, $ban, $server, 0, 1);
+ }
+ foreach my $except (@$exceptarray) {
+ process_ban($cn, $except, $server, 128, 1);
+ }
+}
+
+sub user_join_multi($$) {
+ my ($chan, $users) = @_;
+ my $cn = $chan->{CHAN};
+ my $seq = $ircline;
+ my $multi_tradeoff = 2; # could use some synthetic-benchmark tuning
+
+ foreach my $user (@$users) {
+ $user->{__ID} = get_user_id($user);
+
+ unless (defined($user->{__ID})) {
+ # This does happen occasionally. it's a BUG.
+ # At least we have a diagnostic for it now.
+ # Normally we'd just get a [useless] warning from the SQL server
+ ircd::debug($user->{NICK}.' has a NULL user->{__ID} in user_join_multi('.$cn.', ...');
+ }
+ }
+
+ $get_joinpart_lock->execute; $get_joinpart_lock->finish;
+
+ $chan_create->execute($seq, $cn);
+
+ $get_user_count->execute($cn);
+ my ($count) = $get_user_count->fetchrow_array;
+
+ if(scalar(@$users) < $multi_tradeoff) {
+ foreach my $user (@$users) {
+ # see note above in get_user_id loop
+ if (defined($user->{__ID})) {
+ $chanjoin->execute($seq, $user->{__ID}, $cn, $user->{__OP});
+ }
+ }
+ }
+ else {
+ my $query = "REPLACE INTO chanuser (seq, nickid, chan, op, joined) VALUES ";
+ foreach my $user (@$users) {
+ # a join(',', list) would be nice but would involve preparing the list first.
+ # I think this will be faster.
+ if (defined($user->{__ID})) {
+ # see note above in get_user_id loop
+ $query .= '('.$dbh->quote($seq).','.
+ $dbh->quote($user->{__ID}).','.
+ $dbh->quote($cn).','.
+ $dbh->quote($user->{__OP}).', 1),';
+ }
+ }
+ $query =~ s/\,$//;
+ $dbh->do($query);
+ }
+
+ $unlock_tables->execute; $unlock_tables->finish;
+
+ my $bot = agent($chan);
+ foreach my $user (@$users) {
+ $user->{AGENT} = $bot;
+ }
+
+ if(initial_synced() and cr_chk_flag($chan, (CRF_CLOSE | CRF_DRONE))) {
+ my ($reason, $opnick, $time) = get_close($chan);
+ my $cmsg = "$cn is closed: $reason";
+ my $preenforce = $enforcers{lc $chan};
+
+ if (cr_chk_flag($chan, CRF_CLOSE)) {
+ kickban_multi($chan, $users, $cmsg);
+ }
+ elsif (cr_chk_flag($chan, CRF_DRONE)) {
+ chan_kill($chan, $cmsg, $users);
+ }
+
+ unless($preenforce) {
+ ircd::settopic($bot, $cn, $opnick, $time, $cmsg);
+
+ my $ml = get_modelock($chan);
+ ircd::setmode($bot, $cn, $ml) if($ml);
+ }
+ }
+
+ if(($count == 0 or !is_agent_in_chan($bot, $cn)) and initial_synced()) {
+ unless (lc($bot) eq lc($csnick)) {
+ unless(is_agent_in_chan($bot, $cn)) {
+ botserv::bot_join($chan);
+ }
+ }
+ }
+
+ return unless synced() and not cr_chk_flag($chan, (CRF_CLOSE | CRF_DRONE));
+
+ my $n;
+ foreach my $user (@$users) {
+ if(do_status($user, $chan)) {
+ $n++;
+ $user->{__DO_WELCOME} = 1;
+ }
+ }
+
+ if($count == 0 and $n) {
+ my ($ml) = get_modelock($chan);
+ ircd::setmode($bot, $cn, $ml) if($ml);
+
+ $get_topic->execute($cn);
+ my ($ntopic, $nsetter, $ntime) = $get_topic->fetchrow_array;
+ ircd::settopic($bot, $cn, $nsetter, $ntime, $ntopic) if $ntopic;
+ }
+
+ ircd::flushmodes();
+
+ if($n) {
+ foreach my $user (@$users) {
+ if ($user->{__DO_WELCOME} and chk_user_flag($user, UF_FINISHED())) {
+ do_welcome($user, $chan);
+ do_greet($user, $chan)
+ if can_do($chan, 'GREET', $user, { NOREPLY => 1 });
+ }
+ }
+ }
+}
+
+sub user_part($$$) {
+ my ($nick, $cn, $reason) = @_;
+
+ my $user = ( ref $nick eq 'HASH' ? $nick : { NICK => $nick });
+
+ user_part_multi($user, [ $cn ], $reason);
+}
+
+sub user_part_multi($$$) {
+# user_join_multi takes a channel and multiple users
+# user_part_multi takes a user and multiple channels
+# There should probably be a user_join_* that takes one user, multiple channels
+# However, it seems that so far, Unreal splits both PART and JOIN (non-SJOIN)
+# into multiple events/cmds. The reason is unclear.
+# Other ircds may not do so.
+# There is also KICK. some IRCds allow KICK #chan user1,user2,...
+# Unreal it's _supposed_ to work, but it does not.
+
+ my ($user, $chanlist, $reason) = @_;
+ my @chans;
+ foreach my $cn (@$chanlist) {
+ push @chans, { CHAN => $cn };
+
+ }
+
+ my $uid = get_user_id($user);
+ my $seq = $ircline;
+
+ $get_joinpart_lock->execute; $get_joinpart_lock->finish;
+
+ foreach my $chan (@chans) {
+ my $cn = $chan->{CHAN};
+ $chanpart->execute($seq, $uid, $cn, $seq, $seq+1000);
+ $get_user_count->execute($cn);
+ $chan->{COUNT} = $get_user_count->fetchrow_array;
+ }
+
+ $unlock_tables->execute; $unlock_tables->finish;
+
+ foreach my $chan (@chans) {
+ channel_emptied($chan) if $chan->{COUNT} == 0;
+ }
+}
+
+sub channel_emptied($) {
+ my ($chan) = @_;
+
+ botserv::bot_part_if_needed(undef, $chan, 'Nobody\'s here', 1);
+ $chan_delete->execute($chan->{CHAN});
+ $wipe_bans->execute($chan->{CHAN});
+}
+
+sub process_kick($$$$) {
+ my ($src, $cn, $target, $reason) = @_;
+ my $tuser = { NICK => $target };
+ user_part($tuser, $cn, 'Kicked by '.$src.' ('.$reason.')');
+
+ my $chan = { CHAN => $cn };
+ if ( !(is_agent($src) or $src =~ /\./ or adminserv::is_ircop({ NICK => $src })) and
+ ({modes::splitmodes(get_modelock($chan))}->{Q}->[0] eq '+') )
+ {
+ my $srcUser = { NICK => $src };
+ #ircd::irckill(agent($chan), $src, "War script detected (kicked $target past +Q in $cn)");
+ nickserv::kline_user($srcUser, 300, "War script detected (kicked $target past +Q in $cn)");
+ # SVSJOIN won't work while they're banned, unless you invite.
+ ircd::invite(agent($chan), $cn, $target);
+ ircd::svsjoin(undef, $target, $cn);
+ unban_user($chan, $tuser);
+ }
+}
+
+sub chan_mode($$$$) {
+ my ($src, $cn, $modes, $args) = @_;
+ my $user = { NICK => $src };
+ my $chan = { CHAN => $cn };
+ my ($sign, $num);
+
+ # XXX This is not quite right, but maybe it's good enough.
+ my $mysync = ($src =~ /\./ ? 0 : 1);
+
+ if($modes !~ /^[beIvhoaq+-]+$/ and (!synced() or $mysync)) {
+ do_modelock($chan, "$modes $args");
+ }
+
+ my $opguard = (!current_message->{SYNC} and cr_chk_flag($chan, CRF_OPGUARD, 1));
+
+ my @perms = ('VOICE', 'HALFOP', 'OP', 'PROTECT');
+ my $unmodes = '-';
+ my @unargs;
+
+ my @modes = split(//, $modes);
+ my @args = split(/ /, $args);
+
+ foreach my $mode (@modes) {
+ if($mode eq '+') { $sign = 1; next; }
+ if($mode eq '-') { $sign = 0; next; }
+
+ my $arg = shift(@args) if($mode =~ $scm or $mode =~ $ocm);
+ my $auser = { NICK => $arg };
+
+ if($mode =~ /^[vhoaq]$/) {
+ next if $arg eq '';
+ next if is_agent($arg);
+ $num = 0 if $mode eq 'v';
+ $num = 1 if $mode eq 'h';
+ $num = 2 if $mode eq 'o';
+ $num = 3 if $mode eq 'a';
+ $num = 4 if $mode eq 'q';
+
+ if($opguard and $sign == 1 and
+ !can_keep_op($user, $chan, $auser, $mode)
+ ) {
+ $unmodes .= $mode;
+ push @unargs, $arg;
+ } else {
+ my $nid = get_user_id($auser) or next;
+ my ($r, $i);
+ do {
+ if($sign) {
+ $r = $chop->execute((2**$num), (2**$num), $nid, $cn);
+ } else {
+ $r = $chdeop->execute((2**$num), (2**$num), $nid, $cn);
+ }
+ $i++;
+ } while($r==0 and $i<10);
+ }
+ }
+ if ($mode eq 'b') {
+ next if $arg eq '';
+ process_ban($cn, $arg, $src, 0, $sign);
+ }
+ if ($mode eq 'e') {
+ next if $arg eq '';
+ process_ban($cn, $arg, $src, 128, $sign);
+ }
+ if ($mode eq 'I') {
+ next;# if $arg eq '';
+ #process_ban($cn, $arg, $src, 128, $sign);
+ }
+ }
+ ircd::setmode(agent($chan), $cn, $unmodes, join(' ', @unargs)) if($opguard and @unargs);
+}
+
+sub process_ban($$$$) {
+ my ($cn, $arg, $src, $type, $sign) = @_;
+
+ my $arg2 = $arg;
+
+ $arg =~ tr/\*\?/\%\_/;
+
+ if ($sign > 0) {
+ $add_ban->execute($cn, $arg, $src, $type);
+ } else {
+ $delete_ban->execute($cn, $arg, $type);
+ $del_tmpban -> execute ($cn, $arg2);
+ }
+}
+sub cs_topicappend {
+ my ($user, $cn, $topicappend) = @_;
+ $get_topic->execute($cn);
+ my ($ntopic, $nsetter, $ntime) = $get_topic->fetchrow_array;
+ my $newtopic;
+ if ($ntopic) {
+ $newtopic = $ntopic . " | " . $topicappend;
+ }
+ else { $newtopic = $topicappend; }
+ cs_topic ($user, { CHAN => $cn }, $newtopic);
+}
+sub cs_topicprepend {
+ my ($user, $cn, $topicprepend) = @_;
+ $get_topic->execute($cn);
+ my ($ntopic, $nsetter, $ntime) = $get_topic->fetchrow_array;
+ my $newtopic;
+ if ($ntopic) {
+ $newtopic = $topicprepend . " | " . $ntopic;
+ }
+ else { $newtopic = $topicprepend; }
+ cs_topic ($user, { CHAN => $cn }, $newtopic);
+}
+sub chan_topic {
+ my ($src, $cn, $setter, $time, $topic) = @_;
+ my $chan = { CHAN => $cn };
+ my $suser = { NICK => $setter, AGENT => agent($chan) };
+
+ return unless is_registered($chan);
+ return if cr_chk_flag($chan, CRF_CLOSE, 1);
+
+ if(current_message->{SYNC}) { # We don't need to undo our own topic changes.
+ $set_topic1->execute($setter, $time, $cn);
+ $set_topic2->execute($cn, $topic);
+ return;
+ }
+
+ if(!synced()) {
+ $get_topic->execute($cn);
+ my ($ntopic, $nsetter, $ntime) = $get_topic->fetchrow_array;
+ if($topic ne '' and $time == $ntime or can_do($chan, 'SETTOPIC', undef, { ACC => 0 })) {
+ $set_topic1->execute($setter, $time, $cn);
+ $set_topic2->execute($cn, $topic);
+ } else {
+ ircd::settopic(agent($chan), $cn, $nsetter, $ntime, $ntopic);
+ }
+ }
+
+ elsif(lc($src) ne lc($setter) or can_do($chan, 'SETTOPIC', $suser)) {
+ $set_topic1->execute($setter, $time, $cn);
+ $set_topic2->execute($cn, $topic);
+ } else {
+ $get_topic->execute($cn);
+ my ($ntopic, $nsetter, $ntime) = $get_topic->fetchrow_array;
+ ircd::settopic(agent($chan), $cn, $nsetter, $ntime, $ntopic);
+ }
+}
+
+sub eos(;$) {
+ my ($server) = @_;
+ my $gsa;
+
+ $get_all_closed_chans->execute(CRF_DRONE|CRF_CLOSE);
+ while(my ($cn, $type, $reason, $opnick, $time) = $get_all_closed_chans->fetchrow_array) {
+ my $chan = { CHAN => $cn };
+
+ my $cmsg = " is closed [$opnick ".gmtime2($time)."]: $reason";
+ if($type == CRF_DRONE) {
+ chan_kill($chan, $cn.$cmsg);
+ } else {
+ ircd::settopic(agent($chan), $cn, $opnick, $time, "Channel".$cmsg);
+ clear_users($chan, "Channel".$cmsg);
+ }
+ }
+
+ while($chanuser_table > 0) { }
+
+ $get_eos_lock->execute(); $get_eos_lock->finish;
+ $get_akick_all->execute();
+ if($server) {
+ $get_status_all_server->execute($server);
+ $gsa = $get_status_all_server;
+ } else {
+ $get_status_all->execute();
+ $gsa = $get_status_all;
+ }
+ #$unlock_tables->execute(); $unlock_tables->finish;
+
+ while(my @akick = $get_akick_all->fetchrow_array) {
+ akickban(@akick);
+ }
+
+ $get_modelock_all->execute();
+ while(my ($cn, $modes, $ml) = $get_modelock_all->fetchrow_array) {
+ $ml = do_modelock_fast($cn, '', $modes, $ml);
+ ircd::setmode(agent({CHAN=>$cn}), $cn, $ml) if $ml;
+ }
+
+ while(my ($cn, $cflags, $agent, $nick, $uid, $uflags, $level, $op, $neverop) = $gsa->fetchrow_array) {
+ my $user = { NICK => $nick, ID => $uid };
+ #next if chk_user_flag($user, UF_FINISHED);
+ $agent = $csnick unless $agent;
+ my $chan = { CHAN => $cn, FLAGS => $cflags, AGENT => $agent };
+
+ set_modes($user, $chan, $level, ($cflags & CRF_OPGUARD)) if not $neverop and $ops[$level] != $op and not $cflags & (CRF_FREEZE | CRF_CLOSE | CRF_DRONE);
+ do_welcome($user, $chan);
+ }
+
+ set_user_flag_all(UF_FINISHED());
+ $unlock_tables->execute(); $unlock_tables->finish;
+ check_expired_bans();
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package hostserv;
+
+use strict;
+
+use SrSv::Text::Format qw(columnar);
+use SrSv::Errors;
+
+use SrSv::HostMask qw(parse_mask);
+
+use SrSv::User qw(get_user_nick get_user_id :flood);
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::NickReg::Flags qw(NRF_NOHIGHLIGHT nr_chk_flag_user);
+use SrSv::NickReg::User qw(is_identified);
+
+use SrSv::MySQL '$dbh';
+use SrSv::MySQL::Glob;
+require SrSv::DB::StubGen;
+
+
+our $hsnick_default = 'HostServ';
+our $hsnick = $hsnick_default;
+
+sub init() {
+import SrSv::DB::StubGen (
+ dbh => $dbh,
+ generator => 'services_mysql_stubgen',
+);
+
+services_mysql_stubgen(
+ [set_vhost => 'INSERT', "REPLACE INTO vhost SELECT id, ?, ?, ?, UNIX_TIMESTAMP() FROM nickreg WHERE nick=?"],
+ [get_vhost => 'ROW', "SELECT vhost.ident, vhost.vhost
+ FROM vhost, nickalias
+ WHERE nickalias.nrid=vhost.nrid AND nickalias.alias=?"],
+ [del_vhost => 'NULL', "DELETE FROM vhost USING vhost, nickreg WHERE nickreg.nick=? AND vhost.nrid=nickreg.id"],
+ [get_matching_vhosts => 'ARRAY', "SELECT nickreg.nick, vhost.ident, vhost.vhost, vhost.adder, vhost.time
+ FROM vhost JOIN nickreg ON (vhost.nrid=nickreg.id)
+ WHERE nickreg.nick LIKE ? AND vhost.ident LIKE ? AND vhost.vhost LIKE ?
+ ORDER BY nickreg.nick"],
+);
+}
+
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT => $dst };
+
+ return if flood_check($user);
+
+ if(lc $cmd eq 'on') {
+ hs_on($user, $src, 0);
+ }
+ elsif(lc $cmd eq 'off') {
+ hs_off($user);
+ }
+ elsif($cmd =~ /^(add|set(host))?$/i) {
+ if (@args == 2) {
+ hs_sethost($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: SETHOST <nick> <[ident@]vhost>');
+ }
+ }
+ elsif($cmd =~ /^del(ete)?$/i) {
+ if (@args == 1) {
+ hs_delhost($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: DELETE <nick>');
+ }
+ }
+ elsif($cmd =~ /^list$/i) {
+ if (@args == 1) {
+ hs_list($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: LIST <nick!vident@vhost>');
+ }
+ }
+ elsif($cmd =~ /^help$/i) {
+ sendhelp($user, 'hostserv', @args)
+ }
+ else { notice($user, "Unknown command."); }
+}
+
+sub hs_on($$;$) {
+ my ($user, $nick, $identify) = @_;
+ my $src = get_user_nick($user);
+
+ unless(nickserv::is_registered($nick)) {
+ notice($user, "Your nick, \002$nick\002, is not registered.");
+ return;
+ }
+
+ if(!$identify and !is_identified($user, $nick)) {
+ notice($user, "You are not identified to \002$nick\002.");
+ return;
+ }
+
+ my ($vident, $vhost) = get_vhost($nick);
+ unless ($vhost) {
+ notice($user, "You don't have a vHost.") unless $identify;
+ return;
+ }
+ if ($vident) {
+ ircd::chgident($hsnick, $src, $vident);
+ }
+ ircd::chghost($hsnick, $src, $vhost);
+
+ notice($user, "Your vHost has been changed to \002".($vident?"$vident\@":'')."$vhost\002");
+}
+
+sub hs_off($) {
+ my ($user) = @_;
+ my $src = get_user_nick($user);
+
+ # This requires a hack that is only known to work in UnrealIRCd 3.2.6 and later.
+ ircd::reset_cloakhost($hsnick, $src);
+
+ notice($user, "vHost reset to cloakhost.");
+}
+
+sub hs_sethost($$$) {
+ my ($user, $target, $vhost) = @_;
+ unless(adminserv::is_svsop($user, adminserv::S_OPER())) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $rootnick = nickserv::get_root_nick($target);
+
+ unless ($rootnick) {
+ notice($user, "\002$target\002 is not registered.");
+ return;
+ }
+
+ my $vident = '';
+ if($vhost =~ /\@/) {
+ ($vident, $vhost) = split(/\@/, $vhost);
+ }
+ my $src = get_user_nick($user);
+ set_vhost($vident, $vhost, $src, $rootnick);
+
+ notice($user, "vHost for \002$target ($rootnick)\002 set to \002".($vident?"$vident\@":'')."$vhost\002");
+}
+
+sub hs_delhost($$) {
+ my ($user, $target) = @_;
+ unless(adminserv::is_svsop($user, adminserv::S_OPER())) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $rootnick = nickserv::get_root_nick($target);
+
+ unless ($rootnick) {
+ notice($user, "\002$target\002 is not registered.");
+ return;
+ }
+
+ del_vhost($rootnick);
+
+ notice($user, "vHost for \002$target ($rootnick)\002 deleted.");
+}
+
+sub hs_list($$) {
+ my ($user, $mask) = @_;
+
+ unless(adminserv::is_svsop($user, adminserv::S_HELP())) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ my ($mnick, $mident, $mhost) = glob2sql(parse_mask($mask));
+
+ $mnick = '%' if($mnick eq '');
+ $mident = '%' if($mident eq '');
+ $mhost = '%' if($mhost eq '');
+
+ my @data;
+ foreach my $vhostEnt (get_matching_vhosts($mnick, $mident, $mhost)) {
+ my ($rnick, $vident, $vhost) = @$vhostEnt;
+ push @data, [$rnick, ($vident?"$vident\@":'').$vhost];
+ }
+
+ notice($user, columnar({TITLE => "vHost list matching \002$mask\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data));
+}
+
+
+### MISCELLANEA ###
+
+
+
+## IRC EVENTS ##
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package memoserv;
+
+use strict;
+#use constant {
+# READ => 1,
+# DEL => 2,
+# ACK => 4,
+# NOEXP => 8
+#};
+
+use SrSv::Agent qw(is_agent);
+
+use SrSv::Time;
+use SrSv::Text::Format qw(columnar);
+use SrSv::Errors;
+
+use SrSv::User qw(get_user_nick get_user_id get_user_agent :flood);
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::Conf2Consts qw( main );
+
+use SrSv::NickReg::Flags;
+use SrSv::NickReg::User qw(is_identified get_nick_user_nicks);
+
+use SrSv::MySQL qw( $dbh :sql_types );
+
+use SrSv::Util qw( makeSeqList seqifyList );
+
+use constant (
+ MAX_MEMO_LEN => 400
+);
+
+our $msnick_default = 'MemoServ';
+our $msnick = $msnick_default;
+
+our (
+ $send_memo, $send_chan_memo, $get_chan_recipients,
+
+ $get_memo_list,
+
+ $get_memo, $get_memo_full, $get_memo_count, $get_unread_memo_count,
+
+ $set_flag,
+
+ $delete_memo, $purge_memos, $delete_all_memos,
+ $memo_chgroot,
+
+ $add_ignore, $get_ignore_num, $del_ignore_nick, $list_ignore, $chk_ignore,
+ $wipe_ignore, $purge_ignore,
+);
+
+sub init() {
+ $send_memo = $dbh->prepare("INSERT INTO memo SELECT ?, id, NULL, UNIX_TIMESTAMP(), NULL, ? FROM nickreg WHERE nick=?");
+ $send_chan_memo = $dbh->prepare("INSERT INTO memo SELECT ?, nickreg.id, ?, ?, NULL, ? FROM chanacc, nickreg
+ WHERE chanacc.chan=? AND chanacc.level >= ? AND chanacc.nrid=nickreg.id
+ AND !(nickreg.flags & ". NRF_NOMEMO() . ")");
+ $get_chan_recipients = $dbh->prepare("SELECT user.nick FROM user, nickid, nickreg, chanacc WHERE
+ user.id=nickid.id AND nickid.nrid=chanacc.nrid AND chanacc.nrid=nickreg.id AND chanacc.chan=?
+ AND level >= ? AND
+ !(nickreg.flags & ". NRF_NOMEMO() . ")");
+
+ $get_memo_list = $dbh->prepare("SELECT memo.src, memo.chan, memo.time, memo.flag, memo.msg FROM memo, nickreg WHERE nickreg.nick=? AND memo.dstid=nickreg.id ORDER BY memo.time ASC");
+
+ $get_memo = $dbh->prepare("SELECT memo.src, memo.chan, memo.time
+ FROM memo JOIN nickreg ON (memo.dstid=nickreg.id) WHERE nickreg.nick=? ORDER BY memo.time ASC LIMIT 1 OFFSET ?");
+ $get_memo->bind_param(2, 0, SQL_INTEGER);
+ $get_memo_full = $dbh->prepare("SELECT memo.src, memo.chan, memo.time, memo.flag, memo.msg FROM memo, nickreg WHERE nickreg.nick=? AND memo.dstid=nickreg.id ORDER BY memo.time ASC LIMIT 1 OFFSET ?");
+ $get_memo_full->bind_param(2, 0, SQL_INTEGER);
+ $get_memo_count = $dbh->prepare("SELECT COUNT(*) FROM memo, nickreg WHERE nickreg.nick=? AND memo.dstid=nickreg.id");
+ $get_unread_memo_count = $dbh->prepare("SELECT COUNT(*) FROM memo, nickreg WHERE nickreg.nick=? AND memo.dstid=nickreg.id AND memo.flag=0");
+
+ $set_flag = $dbh->prepare("UPDATE memo, nickreg SET memo.flag=? WHERE memo.src=? AND nickreg.nick=? AND memo.dstid=nickreg.id AND memo.chan=? AND memo.time=?");
+
+ $delete_memo = $dbh->prepare("DELETE FROM memo USING memo, nickreg WHERE memo.src=? AND nickreg.nick=? AND memo.dstid=nickreg.id AND memo.chan=? AND memo.time=?");
+ $purge_memos = $dbh->prepare("DELETE FROM memo USING memo, nickreg WHERE nickreg.nick=? AND memo.dstid=nickreg.id AND memo.flag=1");
+ $delete_all_memos = $dbh->prepare("DELETE FROM memo USING memo, nickreg WHERE nickreg.nick=? AND memo.dstid=nickreg.id");
+
+ $add_ignore = $dbh->prepare("INSERT INTO ms_ignore (ms_ignore.nrid, ms_ignore.ignoreid, time)
+ SELECT nickreg.id, ignorenick.id, UNIX_TIMESTAMP() FROM nickreg, nickreg AS ignorenick
+ WHERE nickreg.nick=? AND ignorenick.nick=?");
+ $del_ignore_nick = $dbh->prepare("DELETE FROM ms_ignore USING ms_ignore
+ JOIN nickreg ON (ms_ignore.nrid=nickreg.id)
+ JOIN nickreg AS ignorenick ON(ms_ignore.ignoreid=ignorenick.id)
+ WHERE nickreg.nick=? AND ignorenick.nick=?");
+ $get_ignore_num = $dbh->prepare("SELECT ignorenick.nick FROM ms_ignore
+ JOIN nickreg ON (ms_ignore.nrid=nickreg.id)
+ JOIN nickreg AS ignorenick ON(ms_ignore.ignoreid=ignorenick.id)
+ WHERE nickreg.nick=?
+ ORDER BY ms_ignore.time LIMIT 1 OFFSET ?");
+ $get_ignore_num->bind_param(2, 0, SQL_INTEGER);
+
+ $list_ignore = $dbh->prepare("SELECT ignorenick.nick, ms_ignore.time
+ FROM ms_ignore, nickreg, nickreg AS ignorenick
+ WHERE nickreg.nick=? AND ms_ignore.nrid=nickreg.id AND ms_ignore.ignoreid=ignorenick.id
+ ORDER BY ms_ignore.time");
+ $chk_ignore = $dbh->prepare("SELECT 1
+ FROM ms_ignore, nickreg, nickreg AS ignorenick
+ WHERE nickreg.nick=? AND ms_ignore.nrid=nickreg.id AND ignorenick.nick=? AND ms_ignore.ignoreid=ignorenick.id");
+
+ $wipe_ignore = $dbh->prepare("DELETE FROM ms_ignore USING ms_ignore JOIN nickreg ON(ms_ignore.nrid=nickreg.id) WHERE nickreg.nick=?");
+ $purge_ignore = $dbh->prepare("DELETE FROM ms_ignore USING ms_ignore JOIN nickreg ON(ms_ignore.ignoreid=nickreg.id) WHERE nickreg.nick=?");
+}
+
+### MEMOSERV COMMANDS ###
+
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT => $dst };
+
+ return if flood_check($user);
+ if($SrSv::IRCd::State::queue_depth > main_conf_highqueue && !adminserv::is_svsop($user)) {
+ notice($user, get_user_agent($user)." is too busy right now. Please try your command again later.");
+ }
+
+ if($cmd =~ /^send$/i) {
+ if(@args >= 2) {
+ my @args = split(/\s+/, $msg, 3);
+ ms_send($user, $args[1], $args[2], 0);
+ } else {
+ notice($user, 'Syntax: SEND <recipient> <message>');
+ }
+ }
+ elsif($cmd =~ /^csend$/i) {
+ if(@args >= 3 and $args[1] =~ /^(?:[uvhas]op|co?f(ounder)?|founder)$/i) {
+ my @args = split(/\s+/, $msg, 4);
+ my $level = chanserv::xop_byname($args[2]);
+ ms_send($user, $args[1], $args[3], $level);
+ } else {
+ notice($user, 'Syntax: CSEND <recipient> <uop|vop|hop|aop|sop|cf|founder> <message>');
+ }
+ }
+ elsif($cmd =~ /^read$/i) {
+ if(@args == 1 and (lc($args[0]) eq 'last' or $args[0] > 0)) {
+ ms_read($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: READ <num|LAST>');
+ }
+ }
+ elsif($cmd =~ /^list$/i) {
+ ms_list($user);
+ }
+ elsif($cmd =~ /^del(ete)?$/i) {
+ if(@args >= 1 and (lc($args[0]) eq 'all' or $args[0] > 0)) {
+ ms_delete($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: DELETE <num|num1-num2|ALL>');
+ }
+ }
+ elsif($cmd =~ /^ign(ore)?$/i) {
+ my $cmd2 = shift @args;
+ if($cmd2 =~ /^a(dd)?$/i) {
+ if(@args == 1) {
+ ms_ignore_add($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax: IGNORE ADD <nick>');
+ }
+ }
+ elsif($cmd2 =~ /^d(el)?$/i) {
+ if(@args == 1) {
+ ms_ignore_del($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax: IGNORE DEL [nick|num]');
+ }
+ }
+ elsif($cmd2 =~ /^l(ist)?$/i) {
+ ms_ignore_list($user);
+ }
+ else {
+ notice($user, 'Syntax: IGNORE <ADD|DEL|LIST> [nick|num]');
+ }
+ }
+ elsif($cmd =~ /^help$/i) {
+ sendhelp($user, 'memoserv', @args);
+ }
+ else {
+ notice($user, "Unrecognized command. For help, type: \002/ms help\002");
+ }
+}
+
+sub ms_send($$$$) {
+ my ($user, $dst, $msg, $level) = @_;
+ my $src = get_user_nick($user);
+
+ my $root = auth($user) or return;
+
+ if(length($msg) > MAX_MEMO_LEN()) {
+ notice($user, 'Memo too long. Maximum memo length is '.MAX_MEMO_LEN().' characters.');
+ return;
+ }
+
+ if($dst =~ /^#/) {
+ my $chan = { CHAN => $dst };
+ unless(chanserv::is_registered($chan)) {
+ notice($user, "$dst is not registered");
+ return;
+ }
+
+ my $srcnick = chanserv::can_do($chan, 'MEMO', $user) or return;
+
+ send_chan_memo($srcnick, $chan, $msg, $level);
+ } else {
+ nickserv::chk_registered($user, $dst) or return;
+
+ if (nr_chk_flag($dst, NRF_NOMEMO(), +1)) {
+ notice($user, "\002$dst\002 is not accepting memos.");
+ return;
+ }
+ $chk_ignore->execute(nickserv::get_root_nick($dst), $root);
+ if ($chk_ignore->fetchrow_array) {
+ notice($user, "\002$dst\002 is not accepting memos.");
+ return;
+ }
+
+ send_memo($src, $dst, $msg);
+ }
+
+ notice($user, "Your memo has been sent.");
+}
+
+sub ms_read($$) {
+ my ($user, $num) = @_;
+ my ($from, $chan, $time, $flag, $msg);
+ my $src = get_user_nick($user);
+
+ my $root = auth($user) or return;
+
+ my @nums;
+ if(lc($num) eq 'last') {
+ $get_memo_count->execute($root);
+ ($num) = $get_memo_count->fetchrow_array;
+ if (!$num) {
+ notice($user, "Memo \002$num\002 not found.");
+ return;
+ }
+ @nums = ($num);
+ } else {
+ @nums = makeSeqList($num);
+ }
+
+ my $count = 0;
+ my @reply;
+ while (my $num = shift @nums) {
+ if (++$count > 5) {
+ push @reply, "You can only read 5 memos at a time.";
+ last;
+ }
+ $get_memo_full->execute($root, $num-1);
+ unless(($from, $chan, $time, $flag, $msg) = $get_memo_full->fetchrow_array) {
+ push @reply, "Memo \002$num\002 not found.";
+ next;
+ }
+ $set_flag->execute(1, $from, $root, $chan, $time);
+ push @reply, "Memo \002$num\002 from \002$from\002 ".
+ ($chan ? "to \002$chan\002 " : "to \002$root\002 ").
+ "at ".gmtime2($time), ' ', ' '.$msg, ' --';
+ }
+ notice($user, @reply);
+}
+
+sub ms_list($) {
+ my ($user) = @_;
+ my ($i, @data, $mnlen, $mclen);
+ my $src = get_user_nick($user);
+
+ my $root = auth($user) or return;
+
+ $get_memo_list->execute($root);
+ while(my ($from, $chan, $time, $flag, $msg) = $get_memo_list->fetchrow_array) {
+ $i++;
+
+ push @data, [
+ ($flag ? '' : "\002") . $i,
+ $from, $chan, gmtime2($time),
+ (length($msg) > 20 ? substr($msg, 0, 17) . '...' : $msg)
+ ];
+ }
+
+ unless(@data) {
+ notice($user, "You have no memos.");
+ return;
+ }
+
+ notice($user, columnar( { TITLE => "Memo list for \002$root\002. To read, type \002/ms read <num>\002",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT) }, @data));
+}
+
+sub ms_delete($@) {
+ my ($user, @args) = @_;
+ my $src = get_user_nick($user);
+
+ my $root = auth($user) or return;
+
+ if(scalar(@args) == 1 and lc($args[0]) eq 'all') {
+ $delete_all_memos->execute($root);
+ notice($user, 'All of your memos have been deleted.');
+ return;
+ }
+ my (@deleted, @notDeleted);
+ foreach my $num (reverse makeSeqList(@args)) {
+ if(int($num) ne $num) { # can this happen, given makeSeqList?
+ notice($user, "\002$num\002 is not an integer number");
+ next;
+ }
+ my ($from, $chan, $time);
+ $get_memo->execute($root, $num-1);
+ if(my ($from, $chan, $time) = $get_memo->fetchrow_array) {
+ $delete_memo->execute($from, $root, $chan, $time);
+ push @deleted, $num;
+ } else {
+ push @notDeleted, $num;
+ }
+ }
+ if(scalar(@deleted)) {
+ my $plural = (scalar(@deleted) == 1);
+ my $msg = sprintf("Memo%s deleted: ".join(', ', seqifyList @deleted), ($plural ? '' : 's'));
+ notice($user, $msg);
+ }
+ if(scalar(@notDeleted)) {
+ my $msg = sprintf("Memos not found: ".join(', ', seqifyList @notDeleted));
+ notice($user, $msg);
+ }
+}
+
+sub ms_ignore_add($$) {
+ my ($user, $nick) = @_;
+ my $src = get_user_nick($user);
+
+ unless(is_identified($user, $src) or adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ my $nickroot = nickserv::get_root_nick($nick);
+ unless ($nickroot) {
+ notice($user, "$nick is not registered");
+ return;
+ }
+
+ my $srcroot = nickserv::get_root_nick($src);
+
+ $add_ignore->execute($srcroot, $nickroot);
+
+ notice($user, "\002$nick\002 (\002$nickroot\002) added to \002$src\002 (\002$srcroot\002) memo ignore list.");
+}
+
+sub ms_ignore_del($$) {
+ my ($user, $entry) = @_;
+ my $src = get_user_nick($user);
+
+ unless(is_identified($user, $src) or adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $srcroot = nickserv::get_root_nick($src);
+
+ my $ignorenick;
+ if (misc::isint($entry)) {
+ $get_ignore_num->execute($srcroot, $entry - 1);
+ ($ignorenick) = $get_ignore_num->fetchrow_array();
+ $get_ignore_num->finish();
+ }
+ my $ret = $del_ignore_nick->execute($srcroot, ($ignorenick ? $ignorenick : $entry));
+ if($ret == 1) {
+ notice($user, "Delete succeeded for ($srcroot): $entry");
+ }
+ else {
+ notice($user, "Delete failed for ($srcroot): $entry. entry does not exist?");
+ }
+}
+
+sub ms_ignore_list($) {
+ my ($user) = @_;
+ my $src = get_user_nick($user);
+
+ unless(is_identified($user, $src) or adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $srcroot = nickserv::get_root_nick($src);
+
+ my @data;
+ $list_ignore->execute($srcroot);
+ while (my ($nick, $time) = $list_ignore->fetchrow_array) {
+ push @data, [$nick, '('.gmtime2($time).')'];
+ }
+
+ notice($user, columnar({TITLE => "Memo ignore list for \002$src\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data));
+}
+
+sub notify($;$) {
+ my ($user, $root) = @_;
+ my (@nicks);
+
+ unless(ref($user)) {
+ $user = { NICK => $user };
+ }
+
+ if($root) { @nicks = ($root) }
+ else { @nicks = nickserv::get_id_nicks($user) }
+
+ my $hasmemos;
+ foreach my $n (@nicks) {
+ $get_unread_memo_count->execute($n);
+ my ($c) = $get_unread_memo_count->fetchrow_array;
+ next unless $c;
+ notice($user, "You have \002$c\002 unread memo(s). " . (@nicks > 1 ? "(\002$n\002) " : ''));
+ $hasmemos = 1;
+ }
+
+ notice($user, "To view them, type: \002/ms list\002") if $hasmemos;
+}
+
+### DATABASE UTILITY FUNCTIONS ###
+
+sub send_memo($$$) {
+ my ($src, $dst, $msg) = @_;
+
+ # This construct is intended to allow agents to send memos.
+ # Unfortunately this is raceable against %nickserv::enforcers.
+ # I don't want to change the %nickserv::enforcers decl tho, s/my/our/
+ $src = (is_agent($src) ? $src : nickserv::get_root_nick($src));
+ $dst = nickserv::get_root_nick($dst);
+
+ $send_memo->execute($src, $msg, $dst);
+ notice_all_nicks($dst, "You have a new memo from \002$src\002. To read it, type: \002/ms read last\002");
+}
+
+sub send_chan_memo($$$$) {
+ my ($src, $chan, $msg, $level) = @_;
+ my $cn = $chan->{CHAN};
+ $src = (is_agent($src) ? $src : nickserv::get_root_nick($src));
+
+ $send_chan_memo->execute($src, $cn, time(), $msg, $cn, $level);
+ # "INSERT INTO memo SELECT ?, nick, ?, ?, 0, ? FROM chanacc WHERE chan=? AND level >= ?"
+
+ $get_chan_recipients->execute($cn, $level);
+ while(my ($u) = $get_chan_recipients->fetchrow_array) {
+ notice({ NICK => $u, AGENT => $msnick },
+ "You have a new memo from \002$src\002 to \002$cn\002. To read it, type: \002/ms read last\002");
+ }
+}
+
+sub notice_all_nicks($$) {
+ my ($nick, $msg) = @_;
+
+ foreach my $u (get_nick_user_nicks $nick) {
+ notice({ NICK => $u, AGENT => $msnick }, $msg);
+ }
+}
+
+sub auth($) {
+ my ($user) = @_;
+ my $src = get_user_nick($user);
+
+ my $root = nickserv::get_root_nick($src);
+ unless($root) {
+ notice($user, "Your nick is not registered.");
+ return 0;
+ }
+
+ unless(is_identified($user, $root)) {
+ notice($user, $err_deny);
+ return 0;
+ }
+
+ return $root;
+}
+
+### IRC EVENTS ###
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package nickserv;
+
+use strict;
+use Time::Local;
+use SrSv::Timer qw(add_timer);
+use SrSv::IRCd::State qw($ircline synced initial_synced %IRCd_capabilities);
+use SrSv::Agent;
+use SrSv::Conf qw(main services sql);
+use SrSv::Conf2Consts qw(main services sql);
+use SrSv::HostMask qw(normalize_hostmask hostmask_to_regexp parse_mask parse_hostmask make_hostmask);
+
+use SrSv::MySQL qw( $dbh :sql_types );
+use SrSv::MySQL::Glob;
+
+use SrSv::Shared qw(%newuser %olduser);
+
+use SrSv::Time;
+use SrSv::Text::Format qw(columnar);
+use SrSv::Errors;
+
+use SrSv::Log;
+
+use SrSv::User '/./';
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::NickReg::Flags;
+use SrSv::NickReg::User '/./';
+use SrSv::Hash::Passwords;
+
+use SrSv::NickControl::Enforcer qw(%enforcers);
+
+use SrSv::Email;
+
+use SrSv::Util qw( makeSeqList );
+
+use SrSv::Debug;
+
+use SrSv::NickReg::NickText;
+
+use SrSv::IPv6;
+
+require SrSv::MySQL::Stub;
+
+use constant {
+ # Clone exception max limit.
+ # This number typically means infinite/no-limit.
+ # It is 2**24-1
+ MAX_LIM => 16777215,
+
+ # This could be made a config option
+ # But our config system currently sucks.
+ MAX_PROFILE => 10,
+ # This value likely cannot be increased very far
+ # as the following limits would apply:
+ # 106 (nick/hostmask), 6 (NOTICE), 30 (destination-nick), 32 (key length) = 174
+ # 510 - 174 = 336
+ # but this does not take into account additional spaces/colons
+ # or reformatting by the SrSv::Format code.
+ # Likely the maximum value is ~300
+ MAX_PROFILE_LEN => 250,
+};
+
+our $nsnick_default = 'NickServ';
+our $nsnick = $nsnick_default;
+
+our $cur_lock;
+our $cnt_lock = 0;
+
+our @protect_short = ('none', 'normal', 'high', 'kill');
+our @protect_long = (
+ 'You will not be required to identify to use this nick.',
+ 'You must identify within 60 seconds to use this nick.',
+ 'You must identify before using this nick.',
+ 'You must identify before using this nick or you will be disconnected.'
+);
+our %protect_level = (
+ 'none' => 0,
+ 'no' => 0,
+ 'false' => 0,
+ 'off' => 0,
+ '0' => 0,
+
+ 'true' => 1,
+ 'yes' => 1,
+ 'on' => 1,
+ 'normal' => 1,
+ '1' => 1,
+
+ 'high' => 2,
+ '2' => 2,
+
+ 'kill' => 3,
+ '3' => 3
+);
+
+our (
+ $nick_check,
+ $nick_create, $nick_create_old, $nick_change, $nick_quit, $nick_delete, $nick_id_delete,
+ $get_quit_empty_chans, $nick_chan_delete, $chan_user_partall,
+ $get_hostless_nicks,
+
+ $get_squit_lock, $squit_users, $squit_nickreg, $get_squit_empty_chans, $squit_lastquit,
+
+ $del_nickchg_id, $add_nickchg, $reap_nickchg,
+
+ $get_nick_inval, $inc_nick_inval,
+ $is_registered,
+ $is_alias_of,
+
+ $get_guest, $set_guest,
+
+ $get_lock, $release_lock,
+
+ $get_umodes, $set_umodes,
+
+ $get_info,
+ $set_vhost, $set_ident, $set_ip,
+ $update_regnick_vhost, $get_regd_time, $get_nickreg_quit,
+
+ $chk_clone_except, $count_clones,
+
+ $set_pass,
+ $set_email,
+
+ $get_root_nick, $get_id_nick, $chk_pass, $identify, $identify_ign, $id_update, $logout, $unidentify, $unidentify_single,
+ $update_lastseen, $quit_update, $update_nickalias_last,
+ $set_protect_level,
+
+ $get_register_lock, $register, $create_alias, $drop, $change_root,
+
+ $get_aliases, $get_glist, $count_aliases, $get_random_alias, $delete_alias, $delete_aliases,
+ $get_all_access, $del_all_access, $change_all_access, $change_akicks, $change_founders,
+ $change_successors, $change_svsops,
+
+ $lock_user_table, $unlock_tables,
+
+ $get_matching_nicks,
+
+ $cleanup_nickid, $cleanup_users, $cleanup_chanuser,
+ $get_dead_users,
+
+ $get_expired, $get_near_expired, $set_near_expired,
+
+ $get_watches, $check_watch, $set_watch, $del_watch, $drop_watch,
+ $get_silences, $check_silence, $set_silence, $del_silence, $drop_silence,
+ $get_silence_by_num,
+ $get_expired_silences, $del_expired_silences,
+
+ $get_seen,
+
+ $set_greet, $get_greet, $get_greet_nick, $del_greet,
+ $get_num_nicktext_type, $drop_nicktext,
+
+ $get_auth_chan, $get_auth_num, $del_auth, $list_auth, $add_auth,
+
+ $del_nicktext,
+
+ $set_umode_ntf, $get_umode_ntf,
+
+ $set_vacation_ntf, $get_vacation_ntf,
+
+ $set_authcode_ntf, $get_authcode_ntf,
+
+ $get_nicks_by_email,
+);
+
+sub init() {
+ $nick_check = $dbh->prepare("SELECT id FROM user WHERE nick=? AND online=0 AND time=?");
+ $nick_create = $dbh->prepare("INSERT INTO user SET nick=?, time=?, inval=0, ident=?, host=?, vhost=?, server=?, modes=?,
+ gecos=?, flags=?, cloakhost=?, online=1");
+# $nick_create = $dbh->prepare("INSERT INTO user SET id=(RAND()*294967293)+1, nick=?, time=?, inval=0, ident=?, host=?, vhost=?, server=?, modes=?, gecos=?, flags=?, cloakhost=?, online=1");
+ $nick_create_old = $dbh->prepare("UPDATE user SET nick=?, ident=?, host=?, vhost=?, server=?, modes=?, gecos=?,
+ flags=?, cloakhost=?, online=1 WHERE id=?");
+ $nick_change = $dbh->prepare("UPDATE user SET nick=?, time=? WHERE nick=?");
+ $nick_quit = $dbh->prepare("UPDATE user SET online=0, quittime=UNIX_TIMESTAMP() WHERE nick=?");
+ $nick_delete = $dbh->prepare("DELETE FROM user WHERE nick=?");
+ $nick_id_delete = $dbh->prepare("DELETE FROM nickid WHERE id=?");
+ $get_quit_empty_chans = $dbh->prepare("SELECT cu2.chan, COUNT(*) AS c
+ FROM chanuser AS cu1, chanuser AS cu2
+ WHERE cu1.nickid=?
+ AND cu1.chan=cu2.chan AND cu1.joined=1 AND cu2.joined=1
+ GROUP BY cu2.chan HAVING c=1 ORDER BY NULL");
+ $nick_chan_delete = $dbh->prepare("DELETE FROM chanuser WHERE nickid=?");
+ $chan_user_partall = $dbh->prepare("UPDATE chanuser SET joined=0 WHERE nickid=?");
+ $get_hostless_nicks = $dbh->prepare("SELECT nick FROM user WHERE vhost='*'");
+
+ $get_squit_lock = $dbh->prepare("LOCK TABLES chanuser WRITE, chanuser AS cu1 READ LOCAL, chanuser AS cu2 READ LOCAL, user WRITE, nickreg WRITE, nickid WRITE, chanban WRITE, chan WRITE, chanreg READ LOCAL, nicktext WRITE");
+ $squit_users = $dbh->prepare("UPDATE chanuser, user
+ SET chanuser.joined=0, user.online=0, user.quittime=UNIX_TIMESTAMP()
+ WHERE user.id=chanuser.nickid AND user.server=?");
+ # Must call squit_nickreg and squit_lastquit before squit_users as it modifies user.online
+ $squit_nickreg = $dbh->prepare("UPDATE nickreg, nickid, user
+ SET nickreg.last=UNIX_TIMESTAMP()
+ WHERE nickreg.id=nickid.nrid AND nickid.id=user.id
+ AND user.online=1 AND user.server=?");
+=cut
+ $squit_lastquit = $dbh->prepare("UPDATE nickid, user, nicktext
+ SET nicktext.data=?
+ WHERE nicktext.nrid=nickid.nrid AND nickid.id=user.id
+ AND user.online=1 AND user.server=?");
+=cut
+ $squit_lastquit = $dbh->prepare("REPLACE INTO nicktext ".
+ "SELECT nickid.nrid, ".NTF_QUIT.", 0, '', ? ".
+ "FROM nickid JOIN user ON (nickid.id=user.id) ".
+ "WHERE user.online=1 AND user.server=?");
+ $get_squit_empty_chans = $dbh->prepare("SELECT cu2.chan, COUNT(*) AS c
+ FROM user, chanuser AS cu1, chanuser AS cu2
+ WHERE user.server=? AND cu1.nickid=user.id
+ AND cu1.chan=cu2.chan AND cu1.joined=1 AND cu2.joined=1
+ GROUP BY cu2.chan HAVING c=1 ORDER BY NULL");
+
+ $del_nickchg_id = $dbh->prepare("DELETE FROM nickchg WHERE nickid=?");
+ $add_nickchg = $dbh->prepare("REPLACE INTO nickchg SELECT ?, id, ? FROM user WHERE nick=?");
+ $reap_nickchg = $dbh->prepare("DELETE FROM nickchg WHERE seq<?");
+
+ $get_nick_inval = $dbh->prepare("SELECT nick, inval FROM user WHERE id=?");
+ $inc_nick_inval = $dbh->prepare("UPDATE user SET inval=inval+1 WHERE id=?");
+
+ $is_registered = $dbh->prepare("SELECT 1 FROM nickalias WHERE alias=?");
+ $is_alias_of = $dbh->prepare("SELECT 1 FROM nickalias AS n1 LEFT JOIN nickalias AS n2 ON n1.nrid=n2.nrid
+ WHERE n1.alias=? AND n2.alias=? LIMIT 1");
+
+ $get_guest = $dbh->prepare("SELECT flags & @{[UF_GUEST]} FROM user WHERE nick=?");
+ $set_guest = $dbh->prepare("UPDATE user SET flags = IF(?, flags | @{[UF_GUEST]}, flags & ~@{[UF_GUEST]})
+ WHERE nick=?");
+
+ $get_lock = $dbh->prepare("SELECT GET_LOCK(?, 10)");
+ $release_lock = $dbh->prepare("SELECT RELEASE_LOCK(?)");
+
+ $get_umodes = $dbh->prepare("SELECT modes FROM user WHERE id=?");
+ $set_umodes = $dbh->prepare("UPDATE user SET modes=? WHERE id=?");
+
+ $get_info = $dbh->prepare("SELECT nickreg.email, nickreg.regd, nickreg.last, nickreg.flags, nickreg.ident,
+ nickreg.vhost, nickreg.gecos, nickalias.last
+ FROM nickreg, nickalias WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+ $get_nickreg_quit = $dbh->prepare("SELECT nicktext.data FROM nickreg, nicktext, nickalias
+ WHERE nickalias.nrid=nickreg.id AND nickalias.alias=? AND
+ (nicktext.nrid=nickreg.id AND nicktext.type=".NTF_QUIT.")");
+ $set_ident = $dbh->prepare("UPDATE user SET ident=? WHERE id=?");
+ $set_vhost = $dbh->prepare("UPDATE user SET vhost=? WHERE id=?");
+ $set_ip = $dbh->prepare("UPDATE user SET ip=?, ipv6=? WHERE id=?");
+ $update_regnick_vhost = $dbh->prepare("UPDATE nickreg,nickid SET nickreg.vhost=?
+ WHERE nickreg.id=nickid.nrid AND nickid.id=?");
+ $get_regd_time = $dbh->prepare("SELECT nickreg.regd FROM nickreg, nickalias
+ WHERE nickalias.nrid=nickreg.id and nickalias.alias=?");
+
+ $chk_clone_except = $dbh->prepare("SELECT
+ GREATEST(IF((user.ip >> (32 - sesexip.mask)) = (sesexip.ip >> (32 - sesexip.mask)), sesexip.lim, 0),
+ IF(IF(sesexname.serv, user.server, user.host) LIKE sesexname.host, sesexname.lim, 0)) AS n
+ FROM user, sesexip, sesexname WHERE user.id=? ORDER BY n DESC LIMIT 1");
+ $count_clones = $dbh->prepare("SELECT COUNT(*) FROM user WHERE ip=? AND online=1");
+
+ $get_root_nick = $dbh->prepare("SELECT nickreg.nick FROM nickreg, nickalias WHERE nickreg.id=nickalias.nrid AND nickalias.alias=?");
+ $get_id_nick = $dbh->prepare("SELECT nickreg.nick FROM nickreg WHERE nickreg.id=?");
+ $identify = $dbh->prepare("INSERT INTO nickid SELECT ?, nickalias.nrid FROM nickalias WHERE alias=?");
+ $identify_ign = $dbh->prepare("INSERT IGNORE INTO nickid SELECT ?, nickalias.nrid FROM nickalias WHERE alias=?");
+ $id_update = $dbh->prepare("UPDATE nickreg, user SET
+ nickreg.last=UNIX_TIMESTAMP(), nickreg.ident=user.ident,
+ nickreg.vhost=user.vhost, nickreg.gecos=user.gecos,
+ nickreg.nearexp=0, nickreg.flags = (nickreg.flags & ~". NRF_VACATION .")
+ WHERE nickreg.nick=? AND user.id=?");
+ $logout = $dbh->prepare("DELETE FROM nickid WHERE id=?");
+ $unidentify = $dbh->prepare("DELETE FROM nickid USING nickreg, nickid WHERE nickreg.nick=? AND nickid.nrid=nickreg.id");
+
+ $update_lastseen = $dbh->prepare("UPDATE nickreg,nickid SET nickreg.last=UNIX_TIMESTAMP()
+ WHERE nickreg.id=nickid.nrid AND nickid.id=?");
+ $update_nickalias_last = $dbh->prepare("UPDATE nickalias SET last=UNIX_TIMESTAMP() WHERE alias=?");
+ $quit_update = $dbh->prepare("REPLACE INTO nicktext
+ SELECT nickreg.id, ".NTF_QUIT().", 0, NULL, ? FROM nickreg, nickid
+ WHERE nickreg.id=nickid.nrid AND nickid.id=?");
+
+ $set_protect_level = $dbh->prepare("UPDATE nickalias SET protect=? WHERE alias=?");
+
+
+ $set_email = $dbh->prepare("UPDATE nickreg, nickalias SET nickreg.email=? WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+
+ $set_pass = $dbh->prepare("UPDATE nickreg, nickalias SET nickreg.pass=? WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+
+ $get_register_lock = $dbh->prepare("LOCK TABLES nickalias WRITE, nickreg WRITE");
+ $register = $dbh->prepare("INSERT INTO nickreg SET nick=?, pass=?, email=?, flags=".NRF_HIDEMAIL().", regd=UNIX_TIMESTAMP(), last=UNIX_TIMESTAMP()");
+ $create_alias = $dbh->prepare("INSERT INTO nickalias SELECT id, ?, NULL, NULL FROM nickreg WHERE nick=?");
+
+ $drop = $dbh->prepare("DELETE FROM nickreg WHERE nick=?");
+
+ $get_aliases = $dbh->prepare("SELECT nickalias.alias FROM nickalias, nickreg WHERE
+ nickalias.nrid=nickreg.id AND nickreg.nick=? ORDER BY nickalias.alias");
+ $get_glist = $dbh->prepare("SELECT nickalias.alias, nickalias.protect, nickalias.last
+ FROM nickalias, nickreg WHERE
+ nickalias.nrid=nickreg.id AND nickreg.nick=? ORDER BY nickalias.alias");
+ $count_aliases = $dbh->prepare("SELECT COUNT(*) FROM nickalias, nickreg WHERE
+ nickalias.nrid=nickreg.id AND nickreg.nick=?");
+ $get_random_alias = $dbh->prepare("SELECT nickalias.alias FROM nickalias, nickreg WHERE
+ nickalias.nrid=nickreg.id AND nickreg.nick=? AND nickalias.alias != nickreg.nick LIMIT 1");
+ $delete_alias = $dbh->prepare("DELETE FROM nickalias WHERE alias=?");
+ $delete_aliases = $dbh->prepare("DELETE FROM nickalias USING nickreg, nickalias WHERE
+ nickalias.nrid=nickreg.id AND nickreg.nick=?");
+
+ $get_all_access = $dbh->prepare("SELECT chanacc.chan, chanacc.level, chanacc.adder, chanacc.time FROM nickalias, chanacc WHERE chanacc.nrid=nickalias.nrid AND nickalias.alias=? ORDER BY chanacc.chan");
+ $del_all_access = $dbh->prepare("DELETE FROM chanacc USING chanacc, nickreg WHERE chanacc.nrid=nickreg.id AND nickreg.nick=?");
+
+ $change_root = $dbh->prepare("UPDATE nickreg SET nick=? WHERE nick=?");
+
+ $unlock_tables = $dbh->prepare("UNLOCK TABLES");
+
+ $get_matching_nicks = $dbh->prepare("SELECT nickalias.alias, nickreg.nick, nickreg.ident, nickreg.vhost FROM nickalias, nickreg WHERE nickalias.nrid=nickreg.id AND nickalias.alias LIKE ? AND nickreg.ident LIKE ? AND nickreg.vhost LIKE ? LIMIT 50");
+
+ $cleanup_chanuser = $dbh->prepare("DELETE FROM chanuser USING chanuser
+ LEFT JOIN user ON (chanuser.nickid=user.id) WHERE user.id IS NULL;");
+ $cleanup_nickid = $dbh->prepare("DELETE FROM nickid USING nickid
+ LEFT JOIN user ON(nickid.id=user.id)
+ WHERE user.id IS NULL");
+ $cleanup_users = $dbh->prepare("DELETE FROM user WHERE online=0 AND quittime>0 AND quittime<?");
+ $get_dead_users = $dbh->prepare("SELECT id,nick,time,online,quittime FROM user
+ WHERE online=0 AND quittime>0 AND quittime<?");
+
+ $get_expired = $dbh->prepare("SELECT nickreg.nick, nickreg.email, nickreg.ident, nickreg.vhost
+ FROM nickreg LEFT JOIN nickid ON(nickreg.id=nickid.nrid)
+ LEFT JOIN svsop ON(nickreg.id=svsop.nrid)
+ WHERE nickid.nrid IS NULL AND svsop.nrid IS NULL ".
+ 'AND ('.(services_conf_nearexpire ? 'nickreg.nearexp!=0 AND' : '').
+ " ( !(nickreg.flags & " . NRF_HOLD . ") AND !(nickreg.flags & " . NRF_VACATION . ") AND nickreg.last<? ) OR
+ ( (nickreg.flags & " . NRF_VACATION . ") AND nickreg.last<? ) ) OR
+ ( (nickreg.flags & ". NRF_EMAILREG .") AND nickreg.last<?)");
+ $get_near_expired = $dbh->prepare("SELECT nickreg.nick, nickreg.email, nickreg.flags, nickreg.last
+ FROM nickreg LEFT JOIN nickid ON(nickreg.id=nickid.nrid)
+ LEFT JOIN svsop ON(nickreg.id=svsop.nrid)
+ WHERE nickid.nrid IS NULL AND svsop.nrid IS NULL AND nickreg.nearexp=0 AND
+ ( ( !(nickreg.flags & " . NRF_HOLD . ") AND !(nickreg.flags & " . NRF_VACATION . ") AND nickreg.last<? ) OR
+ ( (nickreg.flags & " . NRF_VACATION . ") AND nickreg.last<? )
+ )");
+ $set_near_expired = $dbh->prepare("UPDATE nickreg SET nearexp=1 WHERE nick=?");
+
+ $get_watches = $dbh->prepare("SELECT watch.mask, watch.time
+ FROM watch
+ JOIN nickalias ON (watch.nrid=nickalias.nrid)
+ WHERE nickalias.alias=?");
+ $check_watch = $dbh->prepare("SELECT 1
+ FROM watch
+ JOIN nickalias ON (watch.nrid=nickalias.nrid)
+ WHERE nickalias.alias=? AND watch.mask=?");
+ $set_watch = $dbh->prepare("INSERT INTO watch SELECT nrid, ?, ? FROM nickalias WHERE alias=?");
+ $del_watch = $dbh->prepare("DELETE FROM watch USING watch
+ JOIN nickalias ON (watch.nrid=nickalias.nrid)
+ WHERE nickalias.alias=? AND watch.mask=?");
+ $drop_watch = $dbh->prepare("DELETE FROM watch
+ USING nickreg JOIN watch ON (watch.nrid=nickreg.id)
+ WHERE nickreg.nick=?");
+ $get_silences = $dbh->prepare("SELECT silence.mask, silence.time, silence.expiry, silence.comment
+ FROM silence
+ JOIN nickalias ON (silence.nrid=nickalias.nrid)
+ WHERE nickalias.alias=? ORDER BY silence.time");
+ $check_silence = $dbh->prepare("SELECT 1 FROM silence
+ JOIN nickalias ON (silence.nrid=nickalias.nrid)
+ WHERE nickalias.alias=? AND silence.mask=?");
+ $set_silence = $dbh->prepare("INSERT INTO silence SELECT nrid, ?, ?, ?, ? FROM nickalias WHERE alias=?");
+ $del_silence = $dbh->prepare("DELETE FROM silence USING silence, nickalias
+ WHERE silence.nrid=nickalias.nrid AND nickalias.alias=? AND silence.mask=?");
+ $drop_silence = $dbh->prepare("DELETE FROM silence USING nickreg, silence
+ WHERE silence.nrid=nickreg.id AND nickreg.nick=?");
+ $get_expired_silences = $dbh->prepare("SELECT nickreg.nick, silence.mask, silence.comment
+ FROM nickreg
+ JOIN silence ON (nickreg.id=silence.nrid)
+ WHERE silence.expiry < UNIX_TIMESTAMP() AND silence.expiry!=0 ORDER BY nickreg.nick");
+ $del_expired_silences = $dbh->prepare("DELETE silence.* FROM silence
+ WHERE silence.expiry < UNIX_TIMESTAMP() AND silence.expiry!=0");
+ $get_silence_by_num = $dbh->prepare("SELECT silence.mask, silence.time, silence.expiry, silence.comment
+ FROM silence
+ JOIN nickalias ON (silence.nrid=nickalias.nrid)
+ WHERE nickalias.alias=? ORDER BY silence.time LIMIT 1 OFFSET ?");
+ $get_silence_by_num->bind_param(2, 0, SQL_INTEGER);
+
+ $get_seen = $dbh->prepare("SELECT nickalias.alias, nickreg.nick, nickreg.last FROM nickreg, nickalias
+ WHERE nickalias.nrid=nickreg.id AND nickalias.alias=?");
+
+ $set_greet = $dbh->prepare("REPLACE INTO nicktext SELECT nickreg.id, ".NTF_GREET.", 0, NULL, ?
+ FROM nickreg, nickalias WHERE nickreg.id=nickalias.nrid AND nickalias.alias=?");
+ $get_greet = $dbh->prepare("SELECT nicktext.data FROM nicktext, nickid
+ WHERE nicktext.nrid=nickid.nrid AND nicktext.type=".NTF_GREET." AND nickid.id=?
+ LIMIT 1");
+ $get_greet_nick = $dbh->prepare("SELECT nicktext.data FROM nicktext, nickalias
+ WHERE nicktext.nrid=nickalias.nrid AND nicktext.type=".NTF_GREET." AND nickalias.alias=?");
+ $del_greet = $dbh->prepare("DELETE nicktext.* FROM nicktext, nickreg, nickalias WHERE
+ nicktext.type=".NTF_GREET." AND nickreg.id=nickalias.nrid AND nickalias.alias=?");
+
+ $get_num_nicktext_type = $dbh->prepare("SELECT COUNT(nicktext.id) FROM nicktext, nickalias
+ WHERE nicktext.nrid=nickalias.nrid AND nickalias.alias=? AND nicktext.type=?");
+ $drop_nicktext = $dbh->prepare("DELETE FROM nicktext USING nickreg
+ JOIN nicktext ON (nicktext.nrid=nickreg.id)
+ WHERE nickreg.nick=?");
+
+ $get_auth_chan = $dbh->prepare("SELECT nicktext.data FROM nicktext, nickalias WHERE
+ nicktext.nrid=nickalias.nrid AND nicktext.type=(".NTF_AUTH().") AND nickalias.alias=? AND nicktext.chan=?");
+ $get_auth_num = $dbh->prepare("SELECT nicktext.chan, nicktext.data FROM nicktext, nickalias WHERE
+ nicktext.nrid=nickalias.nrid AND nicktext.type=(".NTF_AUTH().") AND nickalias.alias=? LIMIT 1 OFFSET ?");
+ $get_auth_num->bind_param(2, 0, SQL_INTEGER);
+ $del_auth = $dbh->prepare("DELETE nicktext.* FROM nicktext, nickalias WHERE
+ nicktext.nrid=nickalias.nrid AND nicktext.type=(".NTF_AUTH().") AND nickalias.alias=? AND nicktext.chan=?");;
+ $list_auth = $dbh->prepare("SELECT nicktext.chan, nicktext.data FROM nicktext, nickalias WHERE
+ nicktext.nrid=nickalias.nrid AND nicktext.type=(".NTF_AUTH().") AND nickalias.alias=?");
+
+ $del_nicktext = $dbh->prepare("DELETE nicktext.* FROM nickreg
+ JOIN nickalias ON (nickalias.nrid=nickreg.id)
+ JOIN nicktext ON (nicktext.nrid=nickreg.id)
+ WHERE nicktext.type=? AND nickalias.alias=?");
+
+ $set_umode_ntf = $dbh->prepare("REPLACE INTO nicktext SELECT nickreg.id, ".NTF_UMODE().", 1, ?, NULL
+ FROM nickreg, nickalias WHERE nickreg.id=nickalias.nrid AND nickalias.alias=?");
+ $get_umode_ntf = $dbh->prepare("SELECT nicktext.chan FROM nickreg, nickalias, nicktext
+ WHERE nicktext.type=(".NTF_UMODE().") AND nicktext.nrid=nickalias.nrid AND nickalias.alias=?");
+
+ $set_vacation_ntf = $dbh->prepare("INSERT INTO nicktext SELECT nickreg.id, ".NTF_VACATION().", 0, ?, NULL
+ FROM nickreg, nickalias WHERE nickreg.id=nickalias.nrid AND nickalias.alias=?");
+ $get_vacation_ntf = $dbh->prepare("SELECT nicktext.chan FROM nickalias, nicktext
+ WHERE nicktext.nrid=nickalias.nrid AND nicktext.type=".NTF_VACATION()." AND nickalias.alias=?");
+
+ $set_authcode_ntf = $dbh->prepare("REPLACE INTO nicktext SELECT nickreg.id, ".NTF_AUTHCODE().", 0, '', ?
+ FROM nickreg, nickalias WHERE nickreg.id=nickalias.nrid AND nickalias.alias=?");
+ $get_authcode_ntf = $dbh->prepare("SELECT 1 FROM nickalias, nicktext
+ WHERE nicktext.nrid=nickalias.nrid AND nicktext.type=".NTF_AUTHCODE()." AND nickalias.alias=? AND nicktext.data=?");
+
+ $get_nicks_by_email = $dbh->prepare("SELECT nickreg.nick, nickreg.ident, nickreg.vhost FROM nickreg
+ WHERE nickreg.email LIKE ? GROUP BY nickreg.nick");
+
+}
+import SrSv::MySQL::Stub {
+ add_profile_ntf => ['INSERT', "REPLACE INTO nicktext SELECT nickreg.id, @{[NTF_PROFILE]}, 0, ?, ?
+ FROM nickreg JOIN nickalias ON (nickreg.id=nickalias.nrid) WHERE nickalias.alias=?"],
+ get_profile_ntf => ['ARRAY', "SELECT chan, data FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_PROFILE]} AND nickalias.alias=?"],
+ del_profile_ntf => ['NULL', "DELETE nicktext.* FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_PROFILE]} AND nickalias.alias=? AND nicktext.chan=?"],
+ wipe_profile_ntf => ['NULL', "DELETE nicktext.* FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_PROFILE]} AND nickalias.alias=?"],
+ count_profile_ntf => ['SCALAR', "SELECT COUNT(chan) FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_PROFILE]} AND nickalias.alias=?"],
+
+ protect_level => ['SCALAR', 'SELECT protect FROM nickalias WHERE alias=?'],
+ get_pass => ['SCALAR', "SELECT nickreg.pass
+ FROM nickreg JOIN nickalias ON (nickreg.id=nickalias.nrid)
+ WHERE nickalias.alias=?"],
+ get_email => ['SCALAR', "SELECT nickreg.email
+ FROM nickalias JOIN nickreg ON (nickreg.id=nickalias.nrid)
+ WHERE nickalias.alias=?"],
+ count_silences => ['SCALAR', "SELECT COUNT(silence.nrid) FROM silence
+ JOIN nickalias ON (silence.nrid=nickalias.nrid)
+ WHERE nickalias.alias=?"],
+ count_watches => ['SCALAR', "SELECT COUNT(watch.nrid) FROM watch
+ JOIN nickalias ON (watch.nrid=nickalias.nrid)
+ WHERE nickalias.alias=?"],
+
+ add_autojoin_ntf => ['INSERT', "INSERT INTO nicktext
+ SELECT nickreg.id, @{[NTF_JOIN]}, 0, ?, NULL
+ FROM nickreg JOIN nickalias ON (nickreg.id=nickalias.nrid)
+ WHERE nickalias.alias=?"],
+ get_autojoin_ntf => ['COLUMN', "SELECT chan
+ FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_JOIN]} AND nickalias.alias=?"],
+ wipe_autojoin_ntf => ['NULL', "DELETE nicktext.* FROM nickreg
+ JOIN nickalias ON (nickalias.nrid=nickreg.id)
+ JOIN nicktext ON (nicktext.nrid=nickreg.id)
+ WHERE nicktext.type=@{[NTF_JOIN]} AND nickalias.alias=?"],
+ del_autojoin_ntf => ['NULL', "DELETE nicktext.* FROM nickreg
+ JOIN nickalias ON (nickalias.nrid=nickreg.id)
+ JOIN nicktext ON (nicktext.nrid=nickreg.id)
+ WHERE nicktext.type=@{[NTF_JOIN]} AND nickalias.alias=? AND nicktext.chan=?"],
+ check_autojoin_ntf => ['SCALAR', "SELECT 1 FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_JOIN]} AND nickalias.alias=? AND nicktext.chan=?"],
+ get_autojoin_by_num => ['SCALAR', "SELECT nicktext.chan
+ FROM nicktext
+ JOIN nickalias ON (nicktext.nrid=nickalias.nrid)
+ WHERE nicktext.type=@{[NTF_JOIN]} AND nickalias.alias=? LIMIT 1 OFFSET ?"],
+};
+
+
+### NICKSERV COMMANDS ###
+
+sub ns_ajoin_list($$) {
+ my ($user, $nick) = @_;
+ my @data;
+ my $i = 0;
+ foreach my $chan (get_autojoin_ntf($nick)) {
+ push @data, [++$i, $chan];
+ }
+
+ notice( $user, columnar( {TITLE => "Channels in \002$nick\002's ajoin",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data ) );
+}
+sub ns_ajoin_del($$@) {
+ my ($user, $nick, @args) = @_;
+ my ($subj, $obj);
+ if(lc(get_user_nick($user)) eq lc($nick)) {
+ $subj='your';
+ $obj='you';
+ } else {
+ $subj="\002$nick\002\'s";
+ $obj="\002$nick\002";
+ }
+ my @entries;
+ foreach my $arg (@args) {
+ if ($arg =~ /^[0-9\.,-]+$/) {
+ foreach my $num (makeSeqList($arg)) {
+ if(my $chan = get_autojoin_by_num($nick, $num - 1)) {
+ push @entries, $chan;
+ } else {
+ notice($user, "No entry \002#$num\002 was found in $subj ajoin list");
+ }
+ }
+ } elsif($arg =~ /^#.*?,#/) {
+ push @entries, split(',', $arg);
+ } else {
+ push @entries, $arg;
+ }
+ }
+ foreach my $entry (@entries) {
+ if(check_autojoin_ntf($nick, $entry)) {
+ del_autojoin_ntf($nick, $entry);
+ notice($user,"Successfully removed \002$entry\002 from $subj ajoin list.");
+ }
+ else {
+ notice($user, "\002$entry\002 was not in $subj ajoin!");
+ }
+ }
+}
+sub ns_ajoin_wipe($$) {
+ my ($user, $nick) = @_;
+ my ($subj, $obj);
+ if(lc(get_user_nick($user)) eq lc($nick)) {
+ $subj='your';
+ $obj='you';
+ } else {
+ $subj="\002$nick\002\'s";
+ $obj="\002$nick\002";
+ }
+ my $count = wipe_autojoin_ntf($nick);
+ if($count) {
+ notice($user,"Successfully wiped \002$count\002 entries from $subj ajoin list.");
+ } else {
+ notice($user,"No entries deleted.");
+ }
+}
+
+sub ns_ajoin_join($$) {
+ my ($user, $nick) = @_;
+ #ns_ajoin_list($user, $nick);
+ do_ajoin($user, $nick);
+}
+
+sub ns_ajoin($@) {
+ my ($user, @args) = @_;
+ my $nick;
+ my $src = get_user_nick($user);
+ my @chans = grep(/^(#|\d)/, @args);
+ my @parms = grep(!/^(#|\d)/, @args);
+ if(scalar(@parms) > 1) {
+ $nick = shift @parms;
+ } else {
+ $nick = $src;
+ }
+ my $cmd = shift @parms;
+ my ($subj, $obj);
+ if(lc($src) eq lc($nick)) {
+ $subj='Your';
+ $obj='You';
+ } else {
+ $subj="\002$nick\002\'s";
+ $obj="\002$nick\002";
+ }
+
+ my $override = adminserv::can_do($user, 'SERVOP');
+ if(is_identified($user, $nick) || $override) {
+ if(!is_registered($src)) {
+ notice($user, "\002$nick\002 is not registered.");
+ return;
+ }
+ } else {
+ notice($user, "Permission denied for \002$nick\002");
+ return;
+ }
+ if ($cmd =~ /^add$/i) {
+ if(!scalar(@chans)) {
+ notice($user, "Syntax: \002AJOIN ADD #channel\002");
+ notice ($user, "Type \002/msg NickServ HELP AJOIN\002 for more help");
+ }
+ foreach my $chanlist (@chans) {
+ if (defined($chanlist) && $chanlist !~ /^#/) {
+ $chanlist = "#" . $chanlist;
+ }
+ foreach my $chan (split(',', $chanlist)) {
+ if(check_autojoin_ntf($nick, $chan)) {
+ notice ($user, $chan . " is already in $subj ajoin list! ");
+ next;
+ } else {
+ add_autojoin_ntf($chan, $nick);
+ notice($user, "\002$chan\002 added to $subj ajoin.");
+ }
+ }
+ }
+ }
+ elsif ($cmd =~ /^list$/i) {
+ ns_ajoin_list($user, $nick);
+ }
+ elsif ($cmd =~ /^join$/i) {
+ ns_ajoin_join($user, $nick);
+ }
+ elsif ($cmd =~ /^del(ete)?$/i) {
+ ns_ajoin_del($user, $nick, @chans);
+ }
+ elsif ($cmd =~ /^(clear|wipe)$/i) {
+ ns_ajoin_wipe($user, $nick);
+ }
+ else {
+ notice($user,"Syntax: AJOIN ADD/DEL/LIST/WIPE");
+ notice ($user,"Type \002/msg NickServ HELP AJOIN\002 for more help!");
+ }
+}
+
+our %high_priority_cmds = (
+ 'id' => 1,
+ 'identify' => 1,
+ 'sid' => 1,
+ 'sidentify' => 1,
+ 'gidentify' => 1,
+ 'ghost' => 1,
+);
+
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT => $dst };
+
+ return if flood_check($user);
+
+ if(!defined($high_priority_cmds{lc $cmd}) &&
+ !adminserv::is_svsop($user) &&
+ $SrSv::IRCd::State::queue_depth > main_conf_highqueue)
+ {
+ notice($user, get_user_agent($user)." is too busy right now. Please try your command again later.");
+ return;
+ }
+
+ if($cmd =~ /^help$/i) {
+ sendhelp($user, 'nickserv', @args)
+ }
+ elsif ($cmd =~ /^ajoin$/i) {
+ ns_ajoin($user, shift @args, @args);
+ }
+ elsif($cmd =~ /^id(entify)?$/i) {
+ if(@args == 1) {
+ ns_identify($user, $src, $args[0]);
+ } elsif(@args == 2) {
+ ns_identify($user, $args[0], $args[1]);
+ } else {
+ notice($user, 'Syntax: IDENTIFY [nick] <password>');
+ }
+ }
+ elsif($cmd =~ /^sid(entify)?$/i) {
+ if(@args == 2) {
+ ns_identify($user, $args[0], $args[1], 1);
+ } else {
+ notice($user, 'Syntax: SIDENTIFY <nick> <password>');
+ }
+ }
+ elsif($cmd =~ /^gid(entify)?$/i) {
+ if(@args == 2) {
+ ns_identify($user, $args[0], $args[1], 2);
+ } else {
+ notice($user, 'Syntax: GIDENTIFY <nick> <password>');
+ }
+ }
+ elsif($cmd =~ /^logout$/i) {
+ ns_logout($user);
+ }
+ elsif($cmd =~ /^release$/i) {
+ if(@args == 1) {
+ ns_release($user, $args[0]);
+ } elsif(@args == 2) {
+ ns_release($user, $args[0], $args[1]);
+ } else {
+ notice($user, 'Syntax: RELEASE <nick> [password]');
+ }
+ }
+ elsif($cmd =~ /^ghost$/i) {
+ if(@args == 1) {
+ ns_ghost($user, $args[0]);
+ } elsif(@args == 2) {
+ ns_ghost($user, $args[0], $args[1]);
+ } else {
+ notice($user, 'Syntax: GHOST <nick> [password]');
+ }
+ }
+ elsif($cmd =~ /^register$/i) {
+ if(@args == 2) {
+ ns_register($user, $args[0], $args[1]);
+ } else {
+ notice($user, 'Syntax: REGISTER <password> <email>');
+ }
+ }
+ elsif($cmd =~ /^(?:link|group)$/i) {
+ if(@args == 2) {
+ ns_link($user, $args[0], $args[1]);
+ } else {
+ notice($user, 'Syntax: LINK <nick> <password>');
+ }
+ }
+ elsif($cmd =~ /^info$/i) {
+ if(@args >= 1) {
+ ns_info($user, @args);
+ } else {
+ notice($user, 'Syntax: INFO <nick> [nick ...]');
+ }
+ }
+ elsif($cmd =~ /^set$/i) {
+ ns_set_parse($user, @args);
+ }
+ elsif($cmd =~ /^(drop|unlink)$/i) {
+ if(@args == 1) {
+ ns_unlink($user, $src, $args[0]);
+ }
+ elsif(@args == 2) {
+ ns_unlink($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax: UNLINK [nick] <password>');
+ }
+ }
+ elsif($cmd =~ /^dropgroup$/i) {
+ if(@args == 1) {
+ ns_dropgroup($user, $src, $args[0]);
+ }
+ elsif(@args == 2) {
+ ns_dropgroup($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax: DROPGROUP [nick] <password>');
+ }
+ }
+ elsif($cmd =~ /^chgroot$/i) {
+ if(@args == 1) {
+ ns_changeroot($user, $src, $args[0]);
+ }
+ elsif(@args == 2) {
+ ns_changeroot($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax: CHGROOT [oldroot] <newroot>');
+ }
+ }
+ elsif($cmd =~ /^sendpass$/i) {
+ if(@args == 1) {
+ ns_sendpass($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: SENDPASS <nick>');
+ }
+ }
+ elsif($cmd =~ /^(?:glist|links)$/i) {
+ if(@args == 0) {
+ ns_glist($user, $src);
+ }
+ elsif(@args >= 1) {
+ ns_glist($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: GLIST [nick] [nick ...]');
+ }
+ }
+ elsif($cmd =~ /^(?:alist|listchans)$/i) {
+ if(@args == 0) {
+ ns_alist($user, $src);
+ }
+ elsif(@args >= 1) {
+ ns_alist($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: ALIST [nick] [nick ...]');
+ }
+ }
+ elsif($cmd =~ /^list$/i) {
+ if(@args == 1) {
+ ns_list($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: LIST <mask>');
+ }
+ }
+ elsif($cmd =~ /^watch$/i) {
+ if ($args[0] =~ /^(add|del|list)$/i) {
+ ns_watch($user, $src, @args);
+ }
+ elsif ($args[1] =~ /^(add|del|list)$/i) {
+ ns_watch($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: WATCH <ADD|DEL|LIST> [nick]');
+ }
+ }
+ elsif($cmd =~ /^silence$/i) {
+ if ($args[0] =~ /^(add|del|list)$/i) {
+ ns_silence($user, $src, @args);
+ }
+ elsif ($args[1] =~ /^(add|del|list)$/i) {
+ ns_silence($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: SILENCE [nick] <ADD|DEL|LIST> [mask] [+expiry] [comment]');
+ }
+ }
+ elsif($cmd =~ /^(acc(ess)?|stat(us)?)$/i) {
+ if (@args >= 1) {
+ ns_acc($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: ACC <nick> [nick ...]');
+ }
+ }
+ elsif($cmd =~ /^seen$/i) {
+ if(@args >= 1) {
+ ns_seen($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: SEEN <nick> [nick ...]');
+ }
+ }
+ elsif($cmd =~ /^recover$/i) {
+ if(@args == 1) {
+ ns_recover($user, $args[0]);
+ } elsif(@args == 2) {
+ ns_recover($user, $args[0], $args[1]);
+ } else {
+ notice($user, 'Syntax: RECOVER <nick> [password]');
+ }
+ }
+ elsif($cmd =~ /^auth$/i) {
+ if (@args >= 1) {
+ ns_auth($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: AUTH [nick] <LIST|ACCEPT|DECLINE> [num|chan]');
+ }
+ }
+ elsif($cmd =~ /^(?:emailreg|(?:auth|email)code)$/i) {
+ if(scalar(@args) >= 2 and scalar(@args) <= 3) {
+ ns_authcode($user, @args);
+ } else {
+ notice($user, 'Syntax: AUTHCODE <nick> <code> [newpassword]');
+ }
+ }
+ elsif($cmd =~ /^profile$/i) {
+ ns_profile($user, @args);
+ }
+ elsif($cmd =~ /^liste?mail/i) {
+ if ($#args == 0) {
+ ns_listemail($user, $args[0]);
+ } else {
+ notice($user, 'Syntax: LISTEMAIL <email@domain.tld>');
+ }
+ }
+ else {
+ notice($user, "Unrecognized command.", "For help, type: \002/msg nickserv help\002");
+ wlog($nsnick, LOG_DEBUG(), "$src tried to use NickServ $msg");
+ }
+}
+
+sub ns_identify($$$;$) {
+ my ($user, $nick, $pass, $svsnick) = @_;
+ my $src = get_user_nick($user);
+
+ my $root = get_root_nick($nick);
+ unless($root) {
+ notice($user, 'Your nick is not registered.');
+ return 0;
+ }
+
+ if($svsnick) {
+ if(lc($src) ne lc($nick) and is_online($nick)) {
+ if($svsnick == 2) {
+ ns_ghost($user, $nick, $pass) or return;
+ } else {
+ notice($user, $nick.' is already in use. Please use GHOST, GIDENTIFY or RECOVER');
+ $svsnick = 0;
+ }
+ }
+ if (is_identified($user, $nick)) {
+ if(lc $src eq lc $nick) {
+ notice($user, "Cannot only change case of nick");
+ return;
+ }
+ ircd::svsnick($nsnick, $src, $nick);
+ ircd::setumode($nsnick, $nick, '+r');
+ return 1;
+ }
+ }
+ # cannot be an else, note change of $svsnick above.
+ if (!$svsnick and is_identified($user, $nick)) {
+ notice($user, 'You are already identified for nick '.$nick.'.');
+ return 0;
+ }
+
+ my $flags = nr_get_flags($root);
+
+ if($flags & NRF_FREEZE) {
+ notice($user, "This nick has been frozen and may not be used.", $err_deny);
+ services::ulog($nsnick, LOG_INFO(), "\00305attempted to identify to frozen nick \003\002$nick\002", $user);
+ return;
+ }
+
+ if($flags & NRF_EMAILREG) {
+ notice($user, "This nick is awaiting an email validation code. Please check your email for instructions.");
+ return;
+ }
+
+ elsif($flags & NRF_SENDPASS) {
+ notice($user, "This nick is awaiting a SENDPASS authentication code. Please check your email for instructions.");
+ return;
+ }
+
+ my $uid = get_user_id($user);
+ unless(chk_pass($root, $pass, $user)) {
+ if(inc_nick_inval($user)) {
+ notice($user, $err_pass);
+ }
+ services::ulog($nsnick, LOG_INFO(), "failed to identify to nick $nick (root: $root)", $user);
+ return 0;
+ }
+
+ return do_identify($user, $nick, $root, $flags, $svsnick);
+}
+
+sub ns_logout($) {
+ my ($user) = @_;
+ my $uid = get_user_id($user);
+
+ $update_lastseen->execute($uid);
+ $logout->execute($uid);
+ delete($user->{NICKFLAGS});
+ ircd::nolag($nsnick, '-', get_user_nick($user));
+ notice($user, 'You are now logged out');
+ services::ulog($nsnick, LOG_INFO(), "used NickServ LOGOUT", $user);
+}
+
+sub ns_release($$;$) {
+ my ($user, $nick, $pass) = @_;
+
+ if(nr_chk_flag($nick, NRF_FREEZE)) {
+ notice($user, "This nick has been frozen and may not be used.", $err_deny);
+ services::ulog($nsnick, LOG_INFO(), "\00305attempted to release frozen nick \003\002$nick\002", $user);
+ return;
+ }
+
+ unless(is_identified($user, $nick)) {
+ if($pass) {
+ my $s = ns_identify($user, $nick, $pass);
+ return if($s == 0); #failed to identify
+ if($s == 1) {
+ notice($user, "Nick $nick is not being held.");
+ return;
+ }
+ } else {
+ notice($user, $err_deny);
+ return;
+ }
+ }
+ elsif(enforcer_quit($nick)) {
+ notice($user, 'Your nick has been released from custody.');
+ } else {
+ notice($user, "Nick $nick is not being held.");
+ }
+}
+
+sub ns_ghost($$;$) {
+
+my @ghostbusters_quotes = (
+ 'Ray. If someone asks if you are a god, you say, "yes!"',
+ 'I feel like the floor of a taxicab.',
+ 'I don\'t have to take this abuse from you, I\'ve got hundreds of people dying to abuse me.',
+ 'He slimed me.',
+ 'This chick is *toast*.',
+ '"Where do these stairs go?" "They go up."',
+ '"That\'s the bedroom, but nothing ever happened in there." "What a crime."',
+ 'NOBODY steps on a church in my town.',
+ 'Whoa, whoa, whoa! Nice shootin\', Tex!',
+ 'It\'s the Stay Puft Marshmallow Man.',
+ '"Symmetrical book stacking. Just like the Philadelphia mass turbulence of 1947." "You\'re right, no human being would stack books like this."',
+ '"Egon, this reminds me of the time you tried to drill a hole through your head. Remember that?" "That would have worked if you hadn\'t stopped me."',
+ '"Ray has gone bye-bye, Egon... what\'ve you got left?" "Sorry, Venkman, I\'m terrified beyond the capacity for rational thought."',
+ 'Listen! Do you smell something?',
+ 'As they say in T.V., I\'m sure there\'s one big question on everybody\'s mind, and I imagine you are the man to answer that. How is Elvis, and have you seen him lately?',
+ '"You know, you don\'t act like a scientist." "They\'re usually pretty stiff." "You\'re more like a game show host."',
+);
+ my ($user, $nick, $pass) = @_;
+ my $src = get_user_nick($user);
+
+ if(nr_chk_flag($nick, NRF_FREEZE)) {
+ notice($user, "This nick has been frozen and may not be used.", $err_deny);
+ services::ulog($nsnick, LOG_INFO(), "\00305attempted to ghost frozen nick \003\002$nick\002", $user);
+ return 0;
+ }
+
+ unless(is_identified($user, $nick)) {
+ if($pass) {
+ my $s = ns_identify($user, $nick, $pass);
+ return 0 if($s == 0); #failed to identify
+ } else {
+ notice($user, $err_deny);
+ return 0;
+ }
+ }
+
+ if(!is_online($nick)) {
+ notice($user, "\002$nick\002 is not online");
+ return 0;
+ } elsif(lc $src eq lc $nick) {
+ notice($user, "I'm sorry, $src, I'm afraid I can't do that.");
+ return 0;
+
+ } else {
+ my $ghostbusters = @ghostbusters_quotes[int rand(scalar(@ghostbusters_quotes))];
+ ircd::irckill($nsnick, $nick, "GHOST command used by $src ($ghostbusters)");
+ notice($user, "Your ghost has been disconnected");
+ services::ulog($nsnick, LOG_INFO(), "used NickServ GHOST on $nick", $user);
+ #nick_delete($nick);
+ return 1;
+ }
+}
+
+sub ns_register($$$) {
+ my ($user, $pass, $email) = @_;
+ my $src = get_user_nick($user);
+
+ if($src =~ /^guest/i) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ unless(validate_email($email)) {
+ notice($user, $err_email);
+ return;
+ }
+
+ if ($pass =~ /pass/i) {
+ notice($user, 'Try a more secure password.');
+ return;
+ }
+
+ my $uid = get_user_id($user);
+
+ $get_register_lock->execute; $get_register_lock->finish;
+
+ if(not is_registered($src)) {
+ $register->execute($src, hash_pass($pass), $email); $register->finish();
+ $create_alias->execute($src, $src); $create_alias->finish;
+ if (defined(services_conf_default_protect)) {
+ $set_protect_level->execute((defined(services_conf_default_protect) ?
+ $protect_level{lc services_conf_default_protect} : 1), $src);
+ $set_protect_level->finish();
+ }
+ $unlock_tables->execute; $unlock_tables->finish;
+
+ if(services_conf_validate_email) {
+ nr_set_flag($src, NRF_EMAILREG());
+ authcode($src, 'emailreg', $email);
+ notice($user, "Your registration is not yet complete.",
+ "Your nick will expire within ".
+ (services_conf_validate_expire == 1 ? '24 hours' : services_conf_validate_expire.' days').
+ " if you do not enter the validation code.",
+ "Check your email for further instructions.");
+ }
+ else {
+ $identify->execute($uid, $src); $identify->finish();
+ notice($user, 'You are now registered and identified.');
+ ircd::setumode($nsnick, $src, '+r');
+ }
+
+ $id_update->execute($src, $uid); $id_update->finish();
+ services::ulog($nsnick, LOG_INFO(), "registered $src (email: $email)".
+ (services_conf_validate_email ? ' requires email validation code' : ''),
+ $user);
+ } else {
+ $unlock_tables->execute; $unlock_tables->finish;
+ notice($user, 'Your nickname has already been registered.');
+ }
+}
+
+sub ns_link($$$) {
+ my ($user, $nick, $pass) = @_;
+
+ my $root = get_root_nick($nick);
+ my $src = get_user_nick($user);
+ my $uid = get_user_id($user);
+
+ if($src =~ /^guest/i) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ unless (is_registered($nick)) {
+ if(is_registered($src)) {
+ notice($user, "The nick \002$nick\002 is not registered. You need to change your nick to \002$nick\002 and then link to \002$src\002.");
+ } else { # if neither $nick nor $src are registered
+ notice($user, "You need to register your nick first. For help, type \002/ns help register");
+ }
+ return;
+ }
+
+ unless(chk_pass($root, $pass, $user)) {
+ notice($user, $err_pass);
+ return;
+ }
+
+ if(nr_chk_flag($nick, NRF_FREEZE) and (lc $pass ne 'force')) {
+ notice($user, "\002$root\002 has been frozen and may not be used.");
+ return;
+ }
+
+ if(is_alias_of($src, $nick)) {
+ notice($user, "\002$nick\002 is already linked to \002$src\002.");
+ return;
+ }
+
+ $get_register_lock->execute; $get_register_lock->finish;
+
+ if(is_registered($src)) {
+ $unlock_tables->execute; $unlock_tables->finish;
+
+ if(is_identified($user, $src)) {
+ notice($user, "You cannot link an already registered nick. Type this and try again: \002/ns drop $src <password>");
+ return;
+ } else {
+ notice($user, 'Your nickname has already been registered.');
+ return;
+ }
+ } else {
+ $create_alias->execute($src, $root); $create_alias->finish();
+ if (defined(services_conf_default_protect)) {
+ $set_protect_level->execute((defined(services_conf_default_protect) ?
+ $protect_level{lc services_conf_default_protect} : 1), $src);
+ $set_protect_level->finish();
+ }
+ $unlock_tables->execute; $unlock_tables->finish;
+
+ if(is_identified($user, $root)) {
+ $identify_ign->execute($uid, $root); $identify_ign->finish();
+ $id_update->execute($root, $uid); $id_update->finish();
+ } else {
+ ns_identify($user, $root, $pass);
+ }
+ }
+
+ notice($user, "\002$src\002 is now linked to \002$root\002.");
+ services::ulog($nsnick, LOG_INFO(), "made $src an alias of $root.", $user);
+
+ check_identify($user);
+}
+
+sub ns_unlink($$$) {
+ my ($user, $nick, $pass) = @_;
+ my $uid = get_user_id($user);
+ my $src = get_user_nick($user);
+
+ my $root = get_root_nick($nick);
+ unless(chk_pass($root, $pass, $user)) {
+ notice($user, $err_pass);
+ return;
+ }
+
+ if(nr_chk_flag($nick, NRF_FREEZE) and (lc $pass ne 'force')) {
+ notice($user, "\002$root\002 has been frozen and may not be used.", $err_deny);
+ services::ulog($nsnick, LOG_INFO(), "\00305attempted to unlink \002$nick\002 from frozen nick \002$root\002", $user);
+ return;
+ }
+
+ if(lc $root eq lc $nick) {
+ $count_aliases->execute($root);
+ my ($count) = $count_aliases->fetchrow_array;
+ if($count == 1) {
+ ns_dropgroup_real($user, $root);
+ return;
+ }
+
+ $get_random_alias->execute($root);
+ my ($new) = $get_random_alias->fetchrow_array;
+ ns_changeroot($user, $root, $new, 1);
+
+ $root = $new;
+ }
+
+ unidentify_single($nick);
+ delete_alias($nick);
+ enforcer_quit($nick);
+
+ notice($user, "\002$nick\002 has been unlinked from \002$root\002.");
+ services::ulog($nsnick, LOG_INFO(), "removed alias $nick from $root.", $user);
+}
+
+sub ns_dropgroup($$$) {
+ my ($user, $nick, $pass) = @_;
+ my $uid = get_user_id($user);
+ my $src = get_user_nick($user);
+ my $root = get_root_nick($nick);
+
+ if(adminserv::get_svs_level($root)) {
+ notice($user, "A nick with services access may not be dropped.");
+ return;
+ }
+
+ unless(chk_pass($root, $pass, $user)) {
+ notice($user, $err_pass);
+ return;
+ }
+
+ if(nr_chk_flag($nick, NRF_FREEZE) and (lc $pass ne 'force')) {
+ notice($user, "This nick has been frozen and may not be used.", $err_deny);
+ services::ulog($nsnick, LOG_INFO(), "\00305attempted to dropgroup frozen nick \002$root\002", $user);
+ return;
+ }
+
+ ns_dropgroup_real($user, $root);
+}
+
+sub ns_dropgroup_real($$) {
+ my ($user, $root) = @_;
+ my $src = get_user_nick($user);
+
+ unidentify($root, "Your nick, \002$root\002, was dropped by \002$src\002.", $src);
+ dropgroup($root);
+ #enforcer_quit($nick);
+ notice($user, "Your nick(s) have been dropped. Thanks for playing.");
+
+ services::ulog($nsnick, LOG_INFO(), "dropped group $root.", $user);
+}
+
+sub ns_changeroot($$$;$) {
+ my ($user, $old, $new, $force) = @_;
+
+ $force or chk_identified($user, $old) or return;
+
+ my $root = get_root_nick($old);
+
+ if(lc($new) eq lc($root)) {
+ notice($user, "\002$root\002 is already your root nick.");
+ return;
+ }
+
+ unless(get_root_nick($new) eq $root) {
+ notice($user, "\002$new\002 is not an alias of your nick. Type \002/msg nickserv help link\002 for information about creating aliases.");
+ return;
+ }
+
+ changeroot($root, $new);
+
+ notice($user, "Your root nick is now \002$new\002.");
+ services::ulog($nsnick, LOG_INFO(), "changed root $root to $new.", $user);
+}
+
+sub ns_info($@) {
+ my ($user, @nicks) = @_;
+
+ foreach my $nick (@nicks) {
+ my $root = get_root_nick($nick);
+
+ $get_info->execute($nick);
+ my @result = $get_info->fetchrow_array;
+ $get_info->finish();
+
+ unless(@result) {
+ notice($user, "The nick \002$nick\002 is not registered.");
+ next;
+ }
+
+ my ($email, $regd, $last, $flags, $ident, $vhost, $gecos, $alias_used) = @result;
+ # the quit entry might not exist if the user hasn't quit yet.
+ $get_nickreg_quit->execute($nick);
+ my ($quit) = $get_nickreg_quit->fetchrow_array(); $get_nickreg_quit->finish();
+ my $hidemail = $flags & NRF_HIDEMAIL;
+
+ $get_greet_nick->execute($nick);
+ my ($greet) = $get_greet_nick->fetchrow_array(); $get_greet_nick->finish();
+ $get_umode_ntf->execute($nick);
+ my ($umode) = $get_umode_ntf->fetchrow_array(); $get_umode_ntf->finish();
+
+ my $svslev = adminserv::get_svs_level($root);
+ my $protect = protect_level($nick);
+ my $showprivate = (is_identified($user, $nick) or
+ adminserv::is_svsop($user, adminserv::S_HELP()));
+
+ my ($seens, $seenm) = do_seen($nick);
+
+ my @data;
+
+ push @data, {FULLROW=>"(Online now, $seenm.)"} if $seens == 2;
+ push @data, ["Last seen:", "$seenm."] if $seens == 1;
+
+ push @data,
+ ["Last seen address:", "$ident\@$vhost"],
+ ["Registered:", gmtime2($regd)];
+ push @data, ["Last used:", ($alias_used ? gmtime2($alias_used) : 'Unknown')] if $showprivate;
+ push @data, ["Last real name:", $gecos];
+
+ push @data, ["Services Rank:", $adminserv::levels[$svslev]]
+ if $svslev;
+ push @data, ["E-mail:", $email] unless $hidemail;
+ push @data, ["E-mail:", "$email (Hidden)"]
+ if($hidemail and $showprivate);
+ push @data, ["Alias of:", $root]
+ if ((lc $root ne lc $nick) and $showprivate);
+
+ my @extra;
+
+ push @extra, "Last quit: $quit" if $quit;
+ push @extra, $protect_long[$protect] if $protect;
+ push @extra, "Does not accept memos." if($flags & NRF_NOMEMO);
+ push @extra, "Cannot be added to channel access lists." if($flags & NRF_NOACC);
+ push @extra, "Will not be automatically opped in channels." if($flags & NRF_NEVEROP);
+ push @extra, "Requires authorization to be added to channel access lists."
+ if($flags & NRF_AUTH);
+ push @extra, "Is frozen and may not be used." if($flags & NRF_FREEZE);
+ push @extra, "Will not expire." if($flags & NRF_HOLD);
+ push @extra, "Is currently on vacation." if($flags & NRF_VACATION);
+ push @extra, "Registration pending email-code verification." if($flags & NRF_EMAILREG);
+ push @extra, "UModes on Identify: ".$umode if ($umode and $showprivate);
+ push @extra, "Greeting: ".$greet if ($greet and $showprivate);
+ push @extra, "Disabled highlighting of alternating lines." if ($flags & NRF_NOHIGHLIGHT);
+
+ notice($user, columnar({TITLE => "NickServ info for \002$nick\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)},
+ @data, {COLLAPSE => \@extra, BULLET => 1}));
+ }
+}
+
+sub ns_set_parse($@) {
+ my ($user, @parms) = @_;
+ my $src = get_user_nick($user);
+# This is a new NS SET parser
+# required due to it's annoying syntax
+#
+# Most commands have only 2 params at most
+# the target (which is implied to be src when not spec'd)
+# However in the case of GREET num-params is unbounded
+#
+# Alternative parsings would be possible,
+# one being to use a regexp for valid set/keys
+ if (lc($parms[1]) eq 'greet') {
+ ns_set($user, @parms);
+ }
+ elsif(lc($parms[0]) eq 'greet') {
+ ns_set($user, $src, @parms);
+ }
+ else {
+ if(@parms == 2) {
+ ns_set($user, $src, $parms[0], $parms[1]);
+ }
+ elsif(@parms == 3) {
+ ns_set($user, $parms[0], $parms[1], $parms[2]);
+ }
+ else {
+ notice($user, 'Syntax: SET [nick] <option> <value>');
+ return;
+ }
+ }
+}
+
+sub ns_set($$$$) {
+ my ($user, $target, $set, @parms) = @_;
+ my $src = get_user_nick($user);
+ my $override = (adminserv::can_do($user, 'SERVOP') or
+ (adminserv::can_do($user, 'FREEZE') and $set =~ /^freeze$/i) ? 1 : 0);
+
+ unless(is_registered($target)) {
+ notice($user, "\002$target\002 is not registered.");
+ return;
+ }
+ unless(is_identified($user, $target) or $override) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ unless (
+ $set =~ /^protect$/i or
+ $set =~ /^e?-?mail$/i or
+ $set =~ /^pass(?:w(?:or)?d)?$/i or
+ $set =~ /^hidee?-?mail$/i or
+ $set =~ /^nomemo$/i or
+ $set =~ /^no(?:acc|op)$/i or
+ $set =~ /^neverop$/i or
+ $set =~ /^auth$/i or
+ $set =~ /^(hold|no-?expire)$/i or
+ $set =~ /^freeze$/i or
+ $set =~ /^vacation$/i or
+ $set =~ /^greet$/i or
+ $set =~ /^u?modes?$/i or
+ $set =~ /^(email)?reg$/i or
+ $set =~ /^nohighlight$/i or
+ $set =~ /^(?:(?:chg)?root|display)$/i
+ ) {
+ notice($user, qq{"$set" is not a valid NickServ setting.});
+ return;
+ }
+
+ my ($subj, $obj);
+ if($src eq $target) {
+ $subj='Your';
+ $obj='You';
+ } else {
+ $subj="\002$target\002\'s";
+ $obj="\002$target\002";
+ }
+ delete($user->{NICKFLAGS});
+
+ if($set =~ /^protect$/i) {
+ my $level = $protect_level{lc shift @parms};
+ unless (defined($level)) {
+ notice($user, "Syntax: SET PROTECT <none|normal|high|kill>");
+ return;
+ }
+
+ $set_protect_level->execute($level, $target);
+ notice($user, "$subj protection level is now set to \002".$protect_short[$level]."\002. ".$protect_long[$level]);
+
+ return;
+ }
+
+ elsif($set =~ /^e?-?mail$/i) {
+ unless(@parms == 1) {
+ notice($user, 'Syntax: SET EMAIL <address>');
+ return;
+ }
+ my $email = $parms[0];
+
+ unless(validate_email($email)) {
+ notice($user, $err_email);
+ return;
+ }
+
+ $set_email->execute($email, $target);
+ notice($user, "$subj email address has been changed to \002$email\002.");
+ services::ulog($nsnick, LOG_INFO(), "changed email of \002$target\002 to $email", $user);
+
+ return;
+ }
+
+ elsif($set =~ /^pass(?:w(?:or)?d)?$/i) {
+ unless(@parms == 1) {
+ notice($user, 'Syntax: SET PASSWD <address>');
+ return;
+ }
+ if($parms[0] =~ /pass/i) {
+ notice($user, 'Try a more secure password.');
+ }
+
+ $set_pass->execute(hash_pass($parms[0]), $target);
+ notice($user, "$subj password has been changed.");
+ services::ulog($nsnick, LOG_INFO(), "changed password of \002$target\002", $user);
+ if(nr_chk_flag($target, NRF_SENDPASS())) {
+ $del_nicktext->execute(NTF_AUTHCODE, $target); $del_nicktext->finish();
+ nr_set_flag($target, NRF_SENDPASS(), 0);
+ }
+
+ return;
+ }
+
+ elsif($set =~ /^greet$/i) {
+ unless(@parms) {
+ notice($user, 'Syntax: SET [nick] GREET <NONE|greeting>');
+ return;
+ }
+
+ my $greet = join(' ', @parms);
+ if ($greet =~ /^(none|off)$/i) {
+ $del_greet->execute($target);
+ notice($user, "$subj greet has been deleted.");
+ services::ulog($nsnick, LOG_INFO(), "deleted greet of \002$target\002", $user);
+ }
+ else {
+ $set_greet->execute($greet, $target);
+ notice($user, "$subj greet has been set to \002$greet\002");
+ services::ulog($nsnick, LOG_INFO(), "changed greet of \002$target\002", $user);
+ }
+
+ return;
+ }
+ elsif($set =~ /^u?modes?$/i) {
+ unless(@parms == 1) {
+ notice($user, 'Syntax: SET UMODE <+modes-modes|none>');
+ return;
+ }
+
+ if (lc $parms[0] eq 'none') {
+ $del_nicktext->execute(NTF_UMODE, $target); $del_nicktext->finish();
+ notice($user, "$obj will not receive any automatic umodes.");
+ }
+ else {
+ my ($modes, $rejected) = modes::allowed_umodes($parms[0]);
+ $del_nicktext->execute(NTF_UMODE, $target); $del_nicktext->finish(); # don't allow dups
+ $set_umode_ntf->execute($modes, $target); $set_umode_ntf->finish();
+ foreach my $usernick (get_nick_user_nicks $target) {
+ ircd::setumode($nsnick, $usernick, $modes)
+ }
+
+ my @out;
+ push @out, "Cannot set these umodes: " . $rejected if $rejected;
+ push @out, "$subj automatic umodes have been set to: \002" . ($modes ? $modes : 'none');
+ notice($user, @out);
+ }
+ return;
+ }
+ elsif($set =~ /^(?:(?:chg)?root|display)$/i) {
+ ns_changeroot($user, $target, $parms[0], $override);
+ return;
+ }
+
+ my $val;
+ if($parms[0] =~ /^(?:no|off|false|0)$/i) { $val = 0; }
+ elsif($parms[0] =~ /^(?:yes|on|true|1)$/i) { $val = 1; }
+ else {
+ notice($user, "Please say \002on\002 or \002off\002.");
+ return;
+ }
+
+ if($set =~ /^hidee?-?mail$/i) {
+ nr_set_flag($target, NRF_HIDEMAIL, $val);
+
+ if($val) {
+ notice($user, "$subj email address is now hidden.");
+ } else {
+ notice($user, "$subj email address is now visible.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^nomemo$/i) {
+ nr_set_flag($target, NRF_NOMEMO, $val);
+
+ if($val) {
+ notice($user, "$subj memos will be blocked.");
+ } else {
+ notice($user, "$subj memos will be delivered.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^no(?:acc|op)$/i) {
+ nr_set_flag($target, NRF_NOACC, $val);
+
+ if($val) {
+ notice($user, "$obj may not be added to channel access lists.");
+ } else {
+ notice($user, "$obj may be added to channel access lists.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^neverop$/i) {
+ nr_set_flag($target, NRF_NEVEROP, $val);
+
+ if($val) {
+ notice($user, "$obj will not be granted status upon joining channels.");
+ } else {
+ notice($user, "$obj will be granted status upon joining channels.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^auth$/i) {
+ nr_set_flag($target, NRF_AUTH, $val);
+
+ if($val) {
+ notice($user, "$obj must now authorize additions to channel access lists.");
+ } else {
+ notice($user, "$obj will not be asked to authorize additions to channel access lists.");
+ }
+
+ return;
+ }
+
+ if($set =~ /^(hold|no-?expire)$/i) {
+ unless (adminserv::can_do($user, 'SERVOP') or
+ is_identified($user, $target) and adminserv::is_ircop($user))
+ {
+ notice($user, $err_deny);
+ return;
+ }
+
+ nr_set_flag($target, NRF_HOLD, $val);
+
+ if($val) {
+ notice($user, "\002$target\002 is now held from expiration.");
+ services::ulog($nsnick, LOG_INFO(), "has held \002$target\002", $user);
+ } else {
+ notice($user, "\002$target\002 will now expire normally.");
+ services::ulog($nsnick, LOG_INFO(), "released \002$target\002 from hold", $user);
+ }
+
+ return;
+ }
+
+ if($set =~ /^freeze$/i) {
+ unless (adminserv::can_do($user, 'FREEZE') or
+ is_identified($user, $target) and adminserv::is_ircop($user))
+ {
+ notice($user, $err_deny);
+ return;
+ }
+
+ nr_set_flag($target, NRF_FREEZE, $val);
+
+ if($val) {
+ notice($user, "\002$target\002 is now frozen.");
+ unidentify($target, "Your nick, \002$target\002, has been frozen and may no longer be used.");
+ services::ulog($nsnick, LOG_INFO(), "froze \002$target\002", $user);
+ } else {
+ notice($user, "\002$target\002 is no longer frozen.");
+ services::ulog($nsnick, LOG_INFO(), "unfroze \002$target\002", $user);
+ }
+
+ return;
+ }
+
+ if($set =~ /^vacation$/i) {
+ if ($val) {
+ $get_regd_time->execute($target);
+ my ($regd) = $get_regd_time->fetchrow_array;
+ $get_regd_time->finish();
+
+ if(($regd > (time() - 86400 * int(services_conf_vacationexpire / 3))) and !$override) {
+ notice($user, "$target is not old enough to use VACATION",
+ 'Minimum age is '.int(services_conf_vacationexpire / 3).' days');
+ return;
+ }
+
+ $get_vacation_ntf->execute($target);
+ my ($last_vacation) = $get_vacation_ntf->fetchrow_array();
+ $get_vacation_ntf->finish();
+ if(defined($last_vacation)) {
+ $last_vacation = unpack('N', MIME::Base64::decode($last_vacation));
+ if ($last_vacation > (time() - 86400 * int(services_conf_vacationexpire / 3)) and !$override) {
+ notice($user, "I'm sorry, \002$src\002, I'm afraid I can't do that.",
+ "Last vacation ended ".gmtime2($last_vacation),
+ 'Minimum time between vacations is '.int(services_conf_vacationexpire / 3).' days.');
+ return;
+ }
+ }
+ }
+
+ nr_set_flag($target, NRF_VACATION, $val);
+
+ services::ulog($nsnick, LOG_INFO(),
+ ($val ? 'enabled' : 'disabled')." vacation mode for \002$target\002", $user);
+ notice($user, "Vacation mode ".($val ? 'enabled' : 'disabled')." for \002$target\002");
+ return;
+ }
+
+ if($set =~ /^(email)?reg$/i) {
+ unless (adminserv::can_do($user, 'SERVOP'))
+ {
+ notice($user, $err_deny);
+ return;
+ }
+
+ nr_set_flag($target, NRF_EMAILREG, $val);
+
+ if($val) {
+ authcode($target, 'emailreg');
+ notice($user, "\002$target\002 now needs an email validation code.");
+ unidentify($target, ["Your nick, \002$target\002, has been flagged for an email validation audit.",
+ "Your nick will expire within 24 hours if you do not enter the validation code.",
+ "Check your email for further instructions."]);
+ services::ulog($nsnick, LOG_INFO(), "requested an email audit for \002$target\002", $user);
+ } else {
+ $del_nicktext->execute(NTF_AUTHCODE, $target); $del_nicktext->finish();
+ notice($user, "\002$target\002 is now fully registered.");
+ services::ulog($nsnick, LOG_INFO(), "validated the email for \002$target\002", $user);
+ }
+
+ return;
+ }
+
+ if($set =~ /^nohighlight$/i) {
+ nr_set_flag($target, NRF_NOHIGHLIGHT, $val);
+
+ if($val) {
+ notice($user, "$obj will no longer have alternative highlighting of lists.");
+ } else {
+ notice($user, "$obj will have alternative highlighting of lists.");
+ }
+
+ return;
+ }
+
+}
+
+sub ns_sendpass($$) {
+ my ($user, $nick) = @_;
+
+ unless(adminserv::is_svsop($user, adminserv::S_HELP() )) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ my $email = get_email($nick);
+
+ unless($email) {
+ notice($user, "\002$nick\002 is not registered or does not have an email address.");
+ return;
+ }
+
+ my $pass = get_pass($nick);
+ if ($pass and !is_hashed($pass)) {
+ send_email($email, "$nsnick Password Reminder",
+ "The password for the nick $nick is:\n$pass");
+ notice($user, "Password for \002$nick\002 has been sent to \002$email\002.");
+ } else {
+ authcode($nick, 'sendpass', $email);
+ nr_set_flag($nick, NRF_SENDPASS);
+ notice($user, "Password authentication code for \002$nick\002 has been sent to \002$email\002.");
+ }
+
+ services::ulog($nsnick, LOG_INFO(), "used SENDPASS on $nick ($email)", $user);
+}
+
+sub ns_glist($@) {
+ my ($user, @targets) = @_;
+
+ foreach my $target (@targets) {
+ my $root = get_root_nick($target);
+ unless($root) {
+ notice $user, "\002$target\002 is not registered.";
+ next;
+ }
+
+ unless(is_identified($user, $target) or
+ adminserv::is_svsop($user, adminserv::S_HELP())
+ ) {
+ notice $user, "$target: $err_deny";
+ next;
+ }
+
+ my @data;
+ $get_glist->execute($root);
+ while(my ($alias, $protect, $last) = $get_glist->fetchrow_array) {
+ my $time_ago;
+ if(0) {
+ # This needs a new NS GLIST cmd, like NS GLISTA or something.
+ # The idea is a command that shows the long version of the time_ago.
+ $time_ago = time_ago($last, 1);
+ } else {
+ $time_ago = time_ago($last);
+ }
+ push @data, ["\002$alias\002", "Protect: $protect_short[$protect]",
+ ($last ? "Last used $time_ago ago" : '')
+ ];
+ }
+
+ notice $user, columnar {TITLE => "Group list for \002$root\002 (" . $get_glist->rows . " nicks):",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data;
+
+ $get_glist->finish();
+ }
+}
+
+sub ns_alist($@) {
+ my ($user, @targets) = @_;
+
+ foreach my $target (@targets) {
+ (adminserv::is_svsop($user, adminserv::S_HELP()) and (
+ chk_registered($user, $target) or next)
+ ) or chk_identified($user, $target) or next;
+
+ my @data;
+
+ $get_all_access->execute($target);
+ while(my ($c, $l, $a, $t) = $get_all_access->fetchrow_array) {
+ next unless $l > 0;
+ push @data, [$c, $chanserv::plevels[$l+$chanserv::plzero], ($a ? "($a)" : ''),
+ gmtime2($t)];
+ }
+
+ notice $user, columnar {TITLE => "Access listing for \002$target\002 (".scalar(@data)." entries)",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data;
+ }
+}
+
+sub ns_list($$) {
+ my ($user, $mask) = @_;
+
+ unless(adminserv::is_svsop($user, adminserv::S_HELP())) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ my ($mnick, $mident, $mhost) = glob2sql(parse_mask($mask));
+
+ $mnick = '%' if($mnick eq '');
+ $mident = '%' if($mident eq '');
+ $mhost = '%' if($mhost eq '');
+
+ my @data;
+ $get_matching_nicks->execute($mnick, $mident, $mhost);
+ while(my ($rnick, $rroot, $rident, $rhost) = $get_matching_nicks->fetchrow_array) {
+ push @data, [$rnick, ($rroot ne $rnick ? $rroot : ''), $rident . '@' . $rhost];
+ }
+
+ notice $user, columnar {TITLE => "Registered nicks matching \002$mask\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data;
+}
+
+sub ns_watch($$$;$) {
+ my ($user, $target, $cmd, $mask) = @_;
+ my $src = get_user_nick($user);
+
+ my $root = get_root_nick($target);
+ unless ($root) {
+ notice($user, "\002$target\002 is not registered.");
+ return;
+ }
+ unless(is_identified($user, $target)) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if ($cmd =~ /^add$/i) {
+ my $max_watches = $IRCd_capabilities{WATCH}; # load here for caching.
+ if(count_watches($root) >= $max_watches) {
+ notice($user, "WATCH list for $target full, there is a limit of $max_watches. Please trim your list.");
+ return;
+ }
+
+ if($mask =~ /\!/ or $mask =~ /\@/) {
+ my ($mnick, $mident, $mhost) = parse_mask($mask);
+ if ($mnick =~ /\*/) {
+ notice($user, "Invalid mask: \002$mask\002",
+ 'A WATCH mask cannot wildcard the nick.');
+ return;
+ }
+ }
+
+ $check_watch->execute($root, $mask);
+ if ($check_watch->fetchrow_array) {
+ notice($user, "\002$mask\002 is already in \002$target\002's watch list.");
+ return;
+ }
+
+ $set_watch->execute($mask, time(), $root);
+ ircd::svswatch($nsnick, $src, "+$mask");
+ notice($user, "\002$mask\002 added to \002$target\002's watch list.");
+ return;
+ }
+ elsif ($cmd =~ /^del(ete)?$/i) {
+ $check_watch->execute($root, $mask);
+ unless ($check_watch->fetchrow_array) {
+ notice($user, "\002$mask\002 is not in \002$target\002's watch list.");
+ return;
+ }
+ $del_watch->execute($root, $mask);
+ ircd::svswatch($nsnick, $src, "-$mask");
+ notice($user, "\002$mask\002 removed from \002$target\002's watch list.");
+ }
+ elsif ($cmd =~ /^list$/i) {
+ my @data;
+
+ $get_watches->execute($root);
+ while(my ($mask, $time) = $get_watches->fetchrow_array) {
+ push @data, [$mask, gmtime2($time)];
+ }
+
+ notice $user, columnar {TITLE => "Watch list for \002$target\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data;
+ }
+ else {
+ notice($user, 'Syntax: WATCH <ADD|DEL|LIST> [nick]');
+ }
+}
+
+sub ns_silence($$$;$@) {
+ my ($user, $target, $cmd, $mask, @args) = @_;
+ my ($expiry, $comment);
+ my $src = get_user_nick($user);
+ my ($subj, $obj);
+ if(lc(get_user_nick($user)) eq lc($target)) {
+ $subj='your';
+ $obj='you';
+ } else {
+ $subj="\002$target\002\'s";
+ $obj="\002$target\002";
+ }
+
+sub get_silence_by_num($$) {
+# This one cannot be converted to SrSv::MySQL::Stub, due to bind_param call
+ my ($nick, $num) = @_;
+ $get_silence_by_num->execute($nick, $num-1);
+ my ($mask) = $get_silence_by_num->fetchrow_array();
+ $get_silence_by_num->finish();
+ return $mask;
+}
+
+ my $root = get_root_nick($target);
+ my $isRegistered;
+ if(!defined($root)) {
+ #notice($user, "\002$target\002 is not registered.");
+ $isRegistered = 0;
+ #return;
+ } else {
+ $isRegistered = 1;
+ }
+
+ if($isRegistered && !is_identified($user, $target)) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if ($cmd =~ /^add$/i) {
+ my $max_silences = $IRCd_capabilities{SILENCE};
+ if(count_silences($root) >= $max_silences) {
+ notice($user, "SILENCE list for $target full, there is a limit of $max_silences. Please trim your list.");
+ return;
+ }
+
+ if (substr($args[0],0,1) eq '+') {
+ $expiry = shift @args;
+ }
+ elsif (substr($args[-1],0,1) eq '+') {
+ $expiry = pop @args;
+ }
+ $comment = join(' ', @args);
+
+ if($mask !~ /[!@.]/) {
+ my $target_user = { NICK => $mask };
+ if(!defined($mask) || !length($mask)) {
+ notice($user, qq{Did not specify a user or hostmask.});
+ return;
+ }
+ elsif(!get_user_id($target_user)) {
+ notice($user, qq{"\002$mask\002" is not a known user, nor a valid hostmask.});
+ return;
+ }
+ $comment = $mask unless $comment;
+ no warnings 'misc';
+ my ($ident, $vhost) = get_vhost($target_user);
+ my ($nick, $ident, $vhost) = make_hostmask(10, $mask, $ident, $vhost);
+ $mask = $nick.'!'.$ident.'@'.$vhost;
+ }
+ else {
+ $mask = normalize_hostmask($mask);
+ }
+
+=cut
+ if("$nsnick!services\@".main_conf_local =~ hostmask_to_regexp($mask)) {
+ notice($user, "You shouldn't add NickServ to your SILENCE list.");
+ return;
+ }
+=cut
+
+ if(defined $expiry) {
+ $expiry = parse_time($expiry) + time();
+ }
+ else {
+ $expiry = 0;
+ };
+ if($isRegistered) {
+ $check_silence->execute($root, $mask);
+ if ($check_silence->fetchrow_array) {
+ notice($user, "\002$mask\002 is already in $subj SILENCE list.");
+ return;
+ }
+
+ $set_silence->execute($mask, time(), $expiry, $comment, $root);
+ }
+ ircd::svssilence($nsnick, $src, "+$mask");
+ notice($user, "\002$mask\002 added to $subj SILENCE list.");
+ }
+ elsif ($cmd =~ /^del(ete)?$/i) {
+ my @masks;
+ if ($mask =~ /^[0-9\.,-]+$/) {
+ foreach my $num (makeSeqList($mask)) {
+ push @masks, get_silence_by_num($root, $num) or next;
+ }
+ if(scalar(@masks) == 0) {
+ notice($user, "Unable to find any silences matching $mask");
+ return;
+ }
+ } else {
+ @masks = ($mask);
+ }
+ my @reply; my @out_masks;
+ foreach my $mask (@masks) {
+ $check_silence->execute($root, $mask);
+ unless ($check_silence->fetchrow_array) {
+ $mask = normalize_hostmask($mask);
+
+ $check_silence->execute($root, $mask);
+ unless ($check_silence->fetchrow_array) {
+ push @reply, "\002$mask\002 is not in $subj SILENCE list.";
+ next;
+ }
+ }
+ $del_silence->execute($root, $mask);
+ push @out_masks, "-$mask";
+ push @reply, "\002$mask\002 removed from $subj SILENCE list.";
+ }
+ ircd::svssilence($nsnick, $src, @out_masks);
+ notice($user, @reply);
+ }
+ elsif ($cmd =~ /^list$/i) {
+ $get_silences->execute($root);
+
+ my @reply; my $i = 1;
+ while(my ($mask, $time, $expiry, $comment) = $get_silences->fetchrow_array) {
+ push @reply, "$i \002[\002 $mask \002]\002 Date added: ".gmtime2($time),
+ ' '.($comment ? "\002[\002 $comment \002]\002 " : '').
+ ($expiry ? 'Expires in '.time_rel($expiry-time()) :
+ "\002[\002 Never expires \002]\002");
+ $i++;
+ }
+
+ notice($user, "SILENCE list for $obj:", (scalar @reply ? @reply : " list empty"));
+ }
+ else {
+ notice($user, 'Syntax: SILENCE [nick] <ADD|DEL|LIST> [mask] [+expiry] [comment]');
+ }
+
+}
+
+sub ns_acc($@) {
+ my ($user, @targets) = @_;
+ my @reply;
+
+ foreach my $target (@targets) {
+ unless(is_registered($target)) {
+ push @reply, "ACC 0 \002$target\002 is not registered.";
+ next;
+ }
+
+ unless(is_online($target)) {
+ push @reply, "ACC 1 \002$target\002 is registered and offline.";
+ next;
+ }
+
+ unless(is_identified({NICK => $target}, $target)) {
+ push @reply, "ACC 2 \002$target\002 is online but not identified.";
+ next;
+ }
+
+ push @reply, "ACC 3 \002$target\002 is registered and identified.";
+ }
+ notice($user, @reply);
+}
+
+sub ns_seen($@) {
+ my ($user, @nicks) = @_;
+
+ foreach my $nick (@nicks) {
+ if(lc $nick eq lc $user->{AGENT}) {
+ notice($user, "Oh, a wise guy, eh?");
+ next;
+ }
+ my ($status, $msg) = do_seen($nick);
+ if($status == 2) {
+ notice($user, "\002$nick\002 is online now, ".$msg.'.');
+ } elsif($status == 1) {
+ notice($user, "\002$nick\002 was last seen ".$msg.'.');
+ } else {
+ notice($user, "The nick \002$nick\002 is not registered.");
+ }
+ }
+}
+
+sub ns_recover($$;$) {
+ my ($user, $nick, $pass) = @_;
+ my $src = get_user_nick($user);
+
+ if(nr_chk_flag($nick, NRF_FREEZE)) {
+ notice($user, "This nick has been frozen and may not be used.", $err_deny);
+ services::ulog($nsnick, LOG_INFO(), "\00305attempted to recover frozen nick \003\002$nick\002", $user);
+ return;
+ }
+
+ unless(is_identified($user, $nick)) {
+ if($pass) {
+ my $s = ns_identify($user, $nick, $pass);
+ return if($s == 0); #failed to identify
+ } else {
+ notice($user, $err_deny);
+ return;
+ }
+ }
+
+ if(!is_online($nick)) {
+ notice($user, "\002$nick\002 is not online");
+ return;
+ } elsif(lc $src eq lc $nick) {
+ notice($user, "I'm sorry, $src, I'm afraid I can't do that.");
+ return;
+
+ } else {
+ collide($nick);
+ notice($user, "User claiming your nick has been collided",
+ "/msg NickServ RELEASE $nick to get it back before the one-minute timeout.");
+ services::ulog($nsnick, LOG_INFO(), "used NickServ RECOVER on $nick", $user);
+ return;
+ }
+}
+
+sub ns_auth($@) {
+ my ($user, @args) = @_;
+ my ($target, $cmd);
+
+#These helpers shouldn't be needed anywhere else.
+# If they ever are, move them to the helpers section
+ sub get_auth_num($$) {
+ # this cannot be converted to SrSv::MySQL::Stub, due to bind_param
+ my ($nick, $num) = @_;
+ $get_auth_num->execute($nick, $num - 1);
+ my ($cn, $data) = $get_auth_num->fetchrow_array();
+ $get_auth_num->finish();
+ return ($data ? ($cn, split(/:/, $data)) : undef);
+ }
+ sub get_auth_chan($$) {
+ my ($nick, $cn) = @_;
+ $get_auth_chan->execute($nick, $cn);
+ my ($data) = $get_auth_chan->fetchrow_array();
+ $get_auth_chan->finish();
+ return (split(/:/, $data));
+ }
+
+ if ($args[0] =~ /^(list|accept|approve|decline|reject)$/i) {
+ $target = get_user_nick($user);
+ $cmd = lc shift @args;
+ }
+ else {
+ $target = shift @args;
+ $cmd = lc shift @args;
+ }
+
+ unless (is_registered($target)) {
+ notice($user, "The nickname \002$target\002 is not registered");
+ return;
+ }
+ unless (is_identified($user, $target)) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if ($cmd eq 'list') {
+ my @data;
+ $list_auth->execute($target);
+ while (my ($cn, $data) = $list_auth->fetchrow_array()) {
+ my ($adder, $old, $level, $time) = split(':', $data);
+ push @data, [$cn, $chanserv::levels[$level], $adder, gmtime2($time)];
+ }
+ if ($list_auth->rows()) {
+ notice $user, columnar {TITLE => "Pending authorizations for \002$target\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data;
+ }
+ else {
+ notice($user, "There are no pending authorizations for \002$target\002");
+ }
+ }
+ elsif ($cmd eq 'accept' or $cmd eq 'approve') {
+ my $parm = shift @args;
+ my ($cn, $adder, $old, $level, $time);
+ if(misc::isint($parm) and
+ ($cn, $adder, $old, $level, $time) = get_auth_num($target, $parm))
+ {
+ }
+ elsif ($parm =~ /^\#/ and
+ ($adder, $old, $level, $time) = get_auth_chan($target, $parm))
+ {
+ $cn = $parm;
+ }
+ unless ($cn) {
+ # This should normally be an 'else' as the elsif above should prove false
+ # For some reason, it doesn't work. the unless ($cn) fixes it.
+ # It only doesn't work for numbered entries
+ notice($user, "There is no entry for \002$parm\002 in \002$target\002's AUTH list");
+ return;
+ }
+ my $chan = { CHAN => $cn };
+ my $root = get_root_nick($target);
+
+ # These next 3 lines should use chanserv::set_acc() but it doesn't seem to work.
+ # It won't let me use a $nick instead of $user
+ $chanserv::set_acc1->execute($cn, $level, $root);
+ $chanserv::set_acc2->execute($level, $adder, $cn, $root);
+ chanserv::set_modes_allnick($root, $chan, $level) unless chanserv::is_neverop($root);
+
+ my $log_str = ($old?'move':'addition')." \002$root\002"
+ . ($old ? ' from the '.$chanserv::levels[$old] : '') .
+ ' to the '.$chanserv::levels[$level]." list of \002$cn\002";
+ services::ulog($chanserv::csnick, LOG_INFO(), "accepted the $log_str from $adder", $user, $chan);
+ notice($user, "You have accepted the $log_str");
+ $del_auth->execute($target, $cn);
+ $del_auth->finish();
+ memoserv::send_memo($chanserv::csnick, $adder, "$target accepted the $log_str");
+ }
+ elsif ($cmd eq 'decline' or $cmd eq 'reject') {
+ my $parm = shift @args;
+ my ($cn, $adder, $old, $level, $time);
+ if(misc::isint($parm) and
+ ($cn, $adder, $old, $level, $time) = get_auth_num($target, $parm))
+ {
+ }
+ elsif ($parm =~ /^\#/ and
+ ($adder, $old, $level, $time) = get_auth_chan($target, $parm))
+ {
+ $cn = $parm;
+ }
+ unless ($cn) {
+ # This should normally be an 'else' as the elsif above should prove false
+ # For some reason, it doesn't work. the unless ($cn) fixes it.
+ # It only doesn't work for numbered entries
+ notice($user, "There is no entry for \002$parm\002 in \002$target\002's AUTH list");
+ return;
+ }
+ my $chan = { CHAN => $cn };
+
+ my $root = get_root_nick($target);
+ my $log_str = ($old?'move':'addition')." \002$root\002"
+ . ($old ? ' from the '.$chanserv::plevels[$old+$chanserv::plzero] : '') .
+ ' to the '.$chanserv::plevels[$level+$chanserv::plzero]." list of \002$cn\002";
+ services::ulog($chanserv::csnick, LOG_INFO(), "declined the $log_str from $adder", $user, $chan);
+ notice($user, "You have declined $log_str");
+ $del_auth->execute($target, $cn);
+ $del_auth->finish();
+ memoserv::send_memo($chanserv::csnick, $adder, "$target declined the $log_str");
+ }
+ #elsif ($cmd eq 'read') {
+ #}
+ else {
+ notice($user, "Unknown AUTH cmd");
+ }
+}
+
+sub ns_authcode($$$;$) {
+ my ($user, $target, $code, $pass) = @_;
+
+ if ($pass and $pass =~ /pass/i) {
+ notice($user, 'Try a more secure password.');
+ return;
+ }
+
+ unless(is_registered($target)) {
+ notice($user, "\002$target\002 isn't registered.");
+ return;
+ }
+
+ if(authcode($target, undef, $code)) {
+ notice($user, "\002$target\002 authenticated.");
+ services::ulog($nsnick, LOG_INFO(), "logged in to \002$target\002 using an authcode", $user);
+
+ do_identify($user, $target, $target);
+ if($pass) {
+ ns_set($user, $target, 'PASSWD', $pass)
+ } elsif(nr_chk_flag($target, NRF_SENDPASS())) {
+ notice($user, "YOU MUST CHANGE YOUR PASSWORD NOW", "/NS SET $target PASSWD <newpassword>");
+ }
+ }
+ else {
+ notice($user, "\002$target\002 authentication failed. Please verify that you typed or pasted the code correctly.");
+ }
+}
+
+sub ns_profile($@) {
+ my ($user, $first, @args) = @_;
+
+ my %profile_dispatch = (
+ 'read' => \&ns_profile_read,
+ 'info' => \&ns_profile_read,
+
+ 'del' => \&ns_profile_del,
+ 'delete' => \&ns_profile_del,
+
+ 'set' => \&ns_profile_update,
+ 'update' => \&ns_profile_update,
+ 'add' => \&ns_profile_update,
+
+ 'wipe' => \&ns_profile_wipe,
+ );
+
+ no warnings 'misc';
+ if(my $sub = $profile_dispatch{$args[0]}) {
+ # Second command with nick
+ shift @args;
+ $sub->($user, $first, @args);
+ }
+ elsif(my $sub = $profile_dispatch{$first}) {
+ # Second command without nick
+ $sub->($user, get_user_nick($user), @args);
+ }
+ elsif(@args == 0) {
+ # No second command
+ ns_profile_read($user, ($first || get_user_nick($user)));
+ }
+ else {
+ notice $user,
+ "Syntax: PROFILE [nick] [SET|DEL|READ|WIPE ...]",
+ "For help, type: \002/ns help profile\002";
+ }
+}
+
+sub ns_profile_read($$@) {
+ my ($user, $target, @args) = @_;
+
+ foreach my $nick ((scalar(@args) ? @args : $target)) {
+ next unless chk_registered($user, $nick);
+ my @profile_entries = get_profile_ntf($nick);
+ if(scalar(@profile_entries)) {
+ notice $user, columnar({TITLE => "Profile information for \002$nick\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)},
+ map( ["$_->[0]:", $_->[1]], @profile_entries )
+ );
+ }
+ else {
+ notice $user, "\002$nick\002 has not created a profile.";
+ }
+ }
+}
+
+sub ns_profile_update($$@) {
+ my ($user, $target, @args) = @_;
+
+ return unless chk_registered($user, $target);
+
+ unless(is_identified($user, $target) or
+ adminserv::is_svsop($user, adminserv::S_HELP())
+ ) {
+ notice($user, "$target: $err_deny");
+ return;
+ }
+
+ my ($key, $data) = (shift @args, join(' ', @args));
+
+ unless ($key and $data) {
+ notice $user, "Syntax: PROFILE [nick] SET <item> <text>",
+ "For help, type: \002/ns help profile\002";
+ return;
+ }
+
+ if(count_profile_ntf($target) >= MAX_PROFILE) {
+ notice($user, "You may not have more than ".MAX_PROFILE." profile items.");
+ return;
+ }
+ elsif (length($key) > 32) {
+ notice($user, "Item name may not be longer than 32 characters.");
+ return;
+ }
+ elsif (length($data) > MAX_PROFILE_LEN) {
+ my $over = length($data) - MAX_PROFILE_LEN;
+ notice($user, "Your entry is $over characters too long. (".MAX_PROFILE_LEN." max.)");
+ return;
+ }
+ add_profile_ntf($key, $data, $target);
+ notice($user, "\002$target\002's \002$key\002 is now \002$data\002");
+}
+
+sub ns_profile_del($$@) {
+ my ($user, $target, @args) = @_;
+
+ return unless chk_registered($user, $target);
+
+ unless(is_identified($user, $target) or
+ adminserv::is_svsop($user, adminserv::S_HELP())
+ ) {
+ notice($user, "$target: $err_deny");
+ return;
+ }
+
+ my $key = shift @args;
+
+ unless ($key) {
+ notice $user, "Syntax: PROFILE [nick] DEL <item>",
+ "For help, type: \002/ns help profile\002";
+ return;
+ }
+
+ if(del_profile_ntf($target, $key) == 0) {
+ notice($user, "There is no profile item \002$key\002 for \002$target\002");
+ } else {
+ notice($user, "Profile item \002$key\002 for \002$target\002 deleted.");
+ }
+}
+
+sub ns_profile_wipe($$@) {
+ my ($user, $target, undef) = @_;
+
+ unless (is_registered($target)) {
+ notice($user, "$target is not registered.");
+ next;
+ }
+ unless(is_identified($user, $target) or
+ adminserv::is_svsop($user, adminserv::S_HELP())
+ ) {
+ notice($user, "$target: $err_deny");
+ return;
+ }
+
+ wipe_profile_ntf($target);
+ notice($user, "Profile for \002$target\002 wiped.");
+}
+
+sub ns_listemail($$) {
+ my ($user, $email) = @_;
+ unless(adminserv::is_svsop($user, adminserv::S_HELP())) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $likeemail = glob2sql($email);
+ my (@found, $count);
+
+ $get_nicks_by_email->execute($likeemail);
+ while (my ($nick, $ident, $host) = $get_nicks_by_email->fetchrow_array) {
+ push @found, " $nick ($ident\@$host)";
+ }
+ $email =~ s/\%/\*/g;
+ if ($#found >= 0) {
+ notice($user, "Nicks matching an email address consisting of \002$email\002");
+ for(@found) {
+ notice($user, $_);
+ $count++;
+ }
+ notice($user, "Found \002$count\002 matching nicks.");
+ } else {
+ notice($user, "There were no nicknames registered with an email address consisting of \002$email\002");
+ }
+}
+
+### MISCELLANEA ###
+
+sub do_seen($$) {
+ my ($nick) = @_;
+ my ($status, $msg);
+
+ $get_seen->execute($nick);
+ if (my ($alias, $root, $lastseen) = $get_seen->fetchrow_array) {
+ if(my @usernicks = get_nick_user_nicks($nick)) {
+ $status = 2;
+ $msg = "using ".(@usernicks==1 ? 'the nick ' : 'the following nicks: ').join(', ', map "\002$_\002", @usernicks);
+ }
+ else {
+ $status = 1;
+ $msg = time_ago($lastseen) . " ago (".gmtime2($lastseen).")";
+ }
+ }
+ else {
+ $status = 0; $msg = undef();
+ }
+
+ return ($status, $msg);
+}
+
+# For a whole group:
+sub unidentify($$;$) {
+ my ($nick, $msg, $src) = @_;
+
+ $nick = get_root_nick($nick);
+
+ foreach my $t (get_nick_user_nicks $nick) {
+ ircd::notice($nsnick, $t, (ref $msg ? @$msg : $msg)) unless(lc $t eq lc $src);
+ if(is_alias_of($nick, $t)) {
+ ircd::setumode($nsnick, $t, '-r');
+ }
+ }
+
+ $unidentify->execute($nick);
+}
+
+# For a single alias:
+sub unidentify_single($$) {
+ my ($nick, $msg) = @_;
+
+ if(is_online($nick)) {
+ ircd::setumode($nsnick, $nick, '-r');
+ }
+}
+
+sub kill_clones($$) {
+ my ($user, $ip) = @_;
+ my $uid = get_user_id($user);
+ my $src = get_user_nick($user);
+
+ return 0 if $ip == 0;
+
+ $chk_clone_except->execute($uid);
+ my ($lim) = $chk_clone_except->fetchrow_array;
+ return 0 if $lim == MAX_LIM();
+ $lim = services_conf_clone_limit unless $lim;
+
+ $count_clones->execute($ip);
+ my ($c) = $count_clones->fetchrow_array;
+
+ if($c > $lim) {
+ ircd::irckill($nsnick, $src, "Session Limit Exceeded");
+ return 1;
+ }
+}
+
+sub do_ajoin($$) {
+ my ($user, $nick) = @_;
+ my $src = get_user_nick($user);
+ if(my @chans = get_autojoin_ntf($nick)) {
+ chanserv::cs_join($user, @chans);
+ }
+}
+
+sub do_identify ($$$;$$) {
+ my ($user, $nick, $root, $flags, $svsnick) = @_;
+ my $uid = get_user_id($user);
+ my $src = get_user_nick($user);
+
+ $identify_ign->execute($uid, $root);
+ $id_update->execute($root, $uid);
+
+ notice($user, 'You are now identified.');
+
+ delete($user->{NICKFLAGS});
+ if($flags & NRF_VACATION) {
+ notice($user, "Welcome back from your vacation, \002$nick\002.");
+ my $ts = MIME::Base64::encode(pack('N', time()));
+ chomp $ts;
+ $del_nicktext->execute(NTF_VACATION, $root); $del_nicktext->finish(); #don't allow dups
+ $set_vacation_ntf->execute($ts, $root);
+ $set_vacation_ntf->finish();
+ }
+
+ $get_umode_ntf->execute($nick);
+ my ($umodes) = $get_umode_ntf->fetchrow_array();
+ $get_umode_ntf->finish();
+ if(adminserv::get_svs_level($root)) {
+ $umodes = modes::merge_umodes('+h', $umodes);
+ ircd::nolag($nsnick, '+', $src);
+ }
+ $umodes = modes::merge_umodes('+r', $umodes) if(is_identified($user, $src));
+
+ hostserv::hs_on($user, $root, 1);
+
+ nickserv::do_svssilence($user, $root);
+ nickserv::do_svswatch($user, $root);
+
+ chanserv::akick_alluser($user);
+ chanserv::set_modes_allchan($user, $flags & NRF_NEVEROP);
+ chanserv::fix_private_join_before_id($user);
+
+ services::ulog($nsnick, LOG_INFO(), "identified to nick $nick (root: $root)", $user);
+
+ memoserv::notify($user, $root);
+ notify_auths($user, $root) if $flags & NRF_AUTH;
+
+ my $enforced;
+ if(enforcer_quit($nick)) {
+ notice($user, 'Your nick has been released from custody.');
+ $enforced = 1;
+ }
+
+ if (lc($src) eq lc($nick)) {
+ ircd::setumode($nsnick, $src, $umodes);
+ $update_nickalias_last->execute($nick); $update_nickalias_last->finish();
+ }
+ elsif($svsnick) {
+ ircd::svsnick($nsnick, $src, $nick);
+ ircd::setumode($nsnick, $nick, modes::merge_umodes('+r', $umodes) );
+ # the update _should_ be taken care of in nick_change()
+ #$update_nickalias_last->execute($nick); $update_nickalias_last->finish();
+ }
+ elsif(defined $umodes) {
+ ircd::setumode($nsnick, $src, $umodes);
+ }
+ do_ajoin($user, $nick);
+ return ($enforced ? 2 : 1);
+}
+
+sub authcode($;$$) {
+ my ($nick, $type, $email) = @_;
+ if($type) {
+ unless (defined($email)) {
+ $email = get_email($nick);
+ }
+
+ my $authcode = misc::gen_uuid(4, 5);
+ $set_authcode_ntf->execute($authcode, $nick); $set_authcode_ntf->finish();
+ send_email($email, "Nick Authentication Code for $nick",
+ "Hello $nick,\n\n".
+
+ "You are receiving this message from the automated nickname\n".
+ "management system of the ".$IRCd_capabilities{NETWORK}." network.\n\n".
+ (lc($type) eq 'emailreg' ?
+ "If you did not try to register your nickname with us, you can\n".
+ "ignore this message. If you continue getting similar e-mails\n".
+ "from us, chances are that someone is intentionally abusing your\n".
+ "e-mail address. Please contact an administrator for help.\n".
+
+ "In order to complete your registration, you must follow the\n".
+ "instructions in this e-mail before ".gmtime2(time+86400)."\n".
+
+ "To complete the registration, the next time you connect, issue the\n".
+ "following command to NickServ:\n\n".
+
+ "After you issue the command, your registration will be complete and\n".
+ "you will be able to use your nickname.\n\n"
+
+ : '').
+ (lc($type) eq 'sendpass' ?
+ "You requested a password authentication code for the nickname '$nick'\n".
+ "on the ".$IRCd_capabilities{'NETWORK'}." IRC Network.\n".
+ "As per our password policies, an authcode has been created for\n".
+ "you and e-mailed to the address you set in NickServ.\n".
+ "To complete the process, you need to return to ".$IRCd_capabilities{'NETWORK'}.",\n".
+ "and execute the following command: \n\n"
+ : '').
+
+ "/NS EMAILCODE $nick $authcode\n\n".
+
+ (lc($type) eq 'sendpass' ?
+ "YOU MUST CHANGE YOUR PASSWORD AT THIS POINT.\n".
+ "You can do so via the following command: \n\n".
+ "/NS SET $nick PASSWD newpassword\n\n".
+ "alternately, try this command: \n\n".
+
+ "/NS EMAILCODE $nick $authcode <password>\n\n"
+ : '').
+
+ "---\n".
+ "If you feel you have gotten this e-mail in error, please contact\n".
+ "an administrator.\n\n".
+
+ "----\n".
+ "If this e-mail came to you unsolicited and appears to be spam -\n".
+ "please e-mail ".main_conf_replyto." with a copy of this e-mail\n".
+ "including all headers.\n\n".
+
+ "Thank you.\n");
+ }
+ else {
+ $get_authcode_ntf->execute($nick, $email);
+ my ($passed) = $get_authcode_ntf->fetchrow_array();
+ $get_authcode_ntf->finish();
+ if ($passed) {
+ nr_set_flag($nick, NRF_EMAILREG(), 0);
+ unless(nr_chk_flag($nick, NRF_SENDPASS)) {
+ $del_nicktext->execute(NTF_AUTHCODE, $nick); $del_nicktext->finish();
+ }
+ return 1;
+ }
+ else {
+ return 0;
+ }
+ }
+}
+
+# This is mostly for logging, be careful using it for anything else
+sub get_hostmask($) {
+ my ($user) = @_;
+ my ($ident, $host);
+ my $src = get_user_nick($user);
+
+ ($ident, $host) = get_host($user);
+
+ return "$src!$ident\@$host";
+}
+
+sub guestnick($) {
+ my ($nick) = @_;
+
+ $set_guest->execute(1, $nick);
+ my $randnick = 'Guest'.int(rand(10)).int(rand(10)).int(rand(10)).int(rand(10)).int(rand(10));
+ #Prevent collisions.
+ while (is_online($randnick)) {
+ $randnick = 'Guest'.int(rand(10)).int(rand(10)).int(rand(10)).int(rand(10)).int(rand(10));
+ }
+ ircd::svsnick($nsnick, $nick, $randnick);
+
+ return $randnick;
+}
+
+sub expire {
+ return if services_conf_noexpire;
+
+=cut
+ my ($ne, $e, $ve, $eve) = (services_conf_nearexpire, services_conf_nickexpire, services_conf_vacationexpire,
+ services_conf_validate_expire);
+=cut
+
+ $get_expired->execute(time() - (86400 * services_conf_nickexpire),
+ time() - (86400 * services_conf_vacationexpire),
+ time() - (86400 * services_conf_validate_expire));
+ while(my ($nick, $email, $ident, $vhost) = $get_expired->fetchrow_array) {
+ dropgroup($nick);
+ wlog($nsnick, LOG_INFO(), "$nick has expired. Email: $email Vhost: $ident\@$vhost");
+ }
+
+ my $time = time();
+
+ return unless services_conf_nearexpire; # if nearexpire is zero, don't.
+ $get_near_expired->execute(
+ $time - (86400 * (services_conf_nickexpire - services_conf_nearexpire)),
+ $time - (86400 * (services_conf_vacationexpire - services_conf_nearexpire))
+ );
+ while(my ($nick, $email, $flags, $last) = $get_near_expired->fetchrow_array) {
+ my $expire_days = services_conf_nearexpire;
+ if ( ( $flags & NRF_VACATION ) and ( $last < time() - (86400 * services_conf_vacationexpire) )
+ or (($last < time() - (86400 * services_conf_nickexpire)) ) )
+ {
+ $expire_days = 0;
+ } elsif ( ( $flags & NRF_VACATION ) and ( $last > time() - (86400 * services_conf_vacationexpire) )
+ or (($last > time() - (86400 * services_conf_nickexpire)) ) )
+ {
+ # this terrible invention is to determine how many days until their nick will expire.
+ # this should almost always be ~7, unless something weird happens like
+ # F_HOLD or svsop status is removed.
+ # int truncates, so we add 0.5.
+ $expire_days = -int(($time - ($last + (86400 *
+ ( ( $flags & NRF_VACATION ) ? services_conf_vacationexpire : services_conf_nickexpire ) )))
+ / 86400 + .5);
+ }
+ if($expire_days >= 1) {
+
+ $get_aliases->execute($nick);
+ my $aliases = $get_aliases->fetchrow_arrayref();
+
+ my $message = "We would like to remind you that your registered nick, $nick, will expire\n".
+ "in approximately $expire_days days unless you sign on and identify.";
+ if(scalar(@$aliases) > 1) {
+ $message .= "\n\nThe following nicks are linked in this group:\n " . join("\n ", @$aliases);
+ }
+
+ send_email($email, "$nsnick Expiration Notice", $message);
+ }
+
+ wlog($nsnick, LOG_INFO(), "$nick will expire ".($expire_days <= 0 ? "today" : "in $expire_days days.")." ($email)");
+ $set_near_expired->execute($nick);
+ }
+}
+
+sub expire_silence_timed {
+ my ($time) = shift;
+ $time = 60 unless $time;
+ add_timer('', $time, __PACKAGE__, 'nickserv::expire_silence_timed');
+
+ find_expired_silences();
+}
+
+# This code is a mess b/c we can only pull one entry at a time
+# and we want to batch the list to the user and to the ircd.
+# our SQL statement explicitly orders the silence entries by nickreg.nick
+sub find_expired_silences() {
+ $get_expired_silences->execute();
+ my ($lastnick, @entries);
+ while(my ($nick, $mask, $comment) = $get_expired_silences->fetchrow_array()) {
+ if ($nick eq $lastnick) {
+ } else {
+ do_expired_silences($lastnick, \@entries);
+ @entries = ();
+ $lastnick = $nick;
+ }
+ push @entries, [$mask, $comment];
+ }
+ if (@entries) {
+ do_expired_silences($lastnick, \@entries);
+ }
+ $get_expired_silences->finish();
+ $del_expired_silences->execute(); $del_expired_silences->finish();
+ return;
+}
+
+sub do_expired_silences($$) {
+ my $nick = $_[0];
+ my (@entries) = @{$_[1]};
+
+ foreach my $user (get_nick_users $nick) {
+ $user->{AGENT} = $nsnick;
+ ircd::svssilence($nsnick, get_user_nick($user), map ( { '-'.$_->[0] } @entries) );
+ #notice($user, "The following SILENCE entries have expired: ".
+ # join(', ', map ( { $_->[0] } @entries) ));
+ notice($user, map( { "The following SILENCE entry has expired: \002".$_->[0]."\002 ".$_->[1] } @entries ) );
+ }
+}
+sub do_svssilence($$) {
+ my ($user, $rootnick) = @_;
+ my $target = get_user_nick($user);
+
+ $get_silences->execute($rootnick);
+ my $count = $get_silences->rows;
+ unless ($get_silences->rows) {
+ $get_silences->finish;
+ return;
+ }
+ my @silences;
+ for(my $i = 1; $i <= $count; $i++) {
+ my ($mask, $time, $expiry) = $get_silences->fetchrow_array;
+ push @silences, "+$mask";
+ }
+ $get_silences->finish;
+ ircd::svssilence($nsnick, $target, @silences);
+ return;
+}
+
+sub do_svswatch($$) {
+ my ($user, $rootnick) = @_;
+ my $target = get_user_nick($user);
+
+ $get_watches->execute($rootnick);
+ my $count = $get_watches->rows;
+ unless ($get_watches->rows) {
+ $get_watches->finish;
+ return;
+ }
+ my @watches;
+ for(my $i = 1; $i <= $count; $i++) {
+ my ($mask, $time, $expiry) = $get_watches->fetchrow_array;
+ push @watches, "+$mask";
+ }
+ $get_watches->finish;
+ ircd::svswatch($nsnick, $target, @watches);
+ return;
+}
+
+sub do_umode($$) {
+ my ($user, $rootnick) = @_;
+ my $target = get_user_nick($user);
+
+ $get_umode_ntf->execute($rootnick);
+ my ($umodes) = $get_umode_ntf->fetchrow_array; $get_umode_ntf->finish();
+
+ ircd::setumode($nsnick, $target, $umodes) if $umodes;
+ return
+}
+
+sub notify_auths($$) {
+ my ($user, $nick) = @_;
+
+ $get_num_nicktext_type->execute($nick, NTF_AUTH);
+ my ($count) = $get_num_nicktext_type->fetchrow_array(); $get_num_nicktext_type->finish();
+ notice($user, "$nick has $count channel authorizations awaiting action.",
+ "To list them, type /ns auth $nick list") if $count;
+}
+
+### PROTECTION AND ENFORCEMENT ###
+
+sub protect($) {
+ my ($nick) = @_;
+
+ return if nr_chk_flag($nick, NRF_EMAILREG());
+ my $lev = protect_level($nick);
+ my $user = { NICK => $nick, AGENT => $nsnick };
+
+ notice($user,
+ "This nickname is registered and protected. If it is your",
+ "nick, type \002/msg NickServ IDENTIFY <password>\002. Otherwise,",
+ "please choose a different nick."
+ ) unless($lev==3);
+
+ if($lev == 1) {
+ warn_countdown("$nick 60");
+ }
+ elsif($lev==2) {
+ collide($nick);
+ }
+ elsif($lev==3) {
+ ircd::svshold($nick, 60, "If this is your nick, type /NS SIDENTIFY $nick \002password\002");
+ kill_user($user, "Unauthorized nick use with KILL protection enabled.");
+ $enforcers{lc $nick} = 1;
+ add_timer($nick, 60, __PACKAGE__, "nickserv::enforcer_delete");
+ }
+
+ return;
+}
+
+sub warn_countdown($) {
+ my ($cookie) = @_;
+ my ($nick, $rem) = split(/ /, $cookie);
+ my $user = { NICK => $nick, AGENT => $nsnick };
+
+ if (is_identified($user, $nick)) {
+ $update_nickalias_last->execute($nick); $update_nickalias_last->finish();
+ return;
+ }
+ elsif(!(is_online($nick)) or !(is_registered($nick))) { return; }
+
+ if($rem == 0) {
+ notice($user, 'Your nick is now being changed.');
+ collide($nick);
+ } else {
+ notice($user,
+ "If you do not identify or change your nick in $rem seconds, your nick will be changed.");
+ $rem -= 20;
+ add_timer("$nick $rem", 20, __PACKAGE__, "nickserv::warn_countdown");
+ }
+}
+
+sub collide($) {
+ my ($nick) = @_;
+
+ ircd::svshold($nick, 60, "If this is your nick, type /NS SIDENTIFY $nick \002password\002");
+ $enforcers{lc $nick} = 1;
+ add_timer($nick, 60, __PACKAGE__, "nickserv::enforcer_delete");
+
+ return guestnick($nick);
+}
+
+sub enforcer_delete($) {
+ my ($nick) = @_;
+ delete($enforcers{lc $nick});
+};
+
+sub enforcer_quit($) {
+ my ($nick) = @_;
+ if($enforcers{lc $nick}) {
+ enforcer_delete($nick);
+ ircd::svsunhold($nick);
+ return 1;
+ }
+ return 0;
+}
+
+### DATABASE UTILITY FUNCTIONS ###
+
+sub get_lock($) {
+ my ($nick) = @_;
+
+ $nick = lc $nick;
+
+ if($cur_lock) {
+ if($cur_lock ne $nick) {
+ really_release_lock($nick);
+ die("Tried to get two locks at the same time");
+ }
+ $cnt_lock++;
+ } else {
+ $cur_lock = $nick;
+ $get_lock->execute(sql_conf_mysql_db.".user.$nick");
+ $get_lock->finish;
+ }
+}
+
+sub release_lock($) {
+ my ($nick) = @_;
+
+ $nick = lc $nick;
+
+ if($cur_lock and $cur_lock ne $nick) {
+ really_release_lock($cur_lock);
+
+ die("Tried to release the wrong lock");
+ }
+
+ if($cnt_lock) {
+ $cnt_lock--;
+ } else {
+ really_release_lock($nick);
+ }
+}
+
+sub really_release_lock($) {
+ my ($nick) = @_;
+
+ $cnt_lock = 0;
+ $release_lock->execute(sql_conf_mysql_db.".user.$nick");
+ $release_lock->finish;
+ undef $cur_lock;
+}
+
+sub get_user_modes($) {
+ my ($user) = @_;
+
+ my $uid = get_user_id($user);
+ $get_umodes->execute($uid);
+ my ($umodes) = $get_umodes->fetchrow_array;
+ $get_umodes->finish();
+ return $umodes;
+};
+
+sub set_vhost($$) {
+ my ($user, $vhost) = @_;
+ my $id = get_user_id($user);
+
+ return $set_vhost->execute($vhost, $id);
+}
+
+sub set_ident($$) {
+ my ($user, $ident) = @_;
+ my $id = get_user_id($user);
+
+ return $set_ident->execute($ident, $id);
+}
+
+sub set_ipv6($$$) {
+ my ($user, $ip, $ipv6) = @_;
+ my $id = get_user_id($user);
+
+ return $set_ip->execute($ip, $ipv6, $id);
+}
+sub set_ip($$) {
+ my ($user, $ip) = @_;
+ my $id = get_user_id($user);
+
+ return $set_ip->execute($ip, undef, $id);
+}
+
+sub get_root_nick($) {
+ my ($nick) = @_;
+
+ $get_root_nick->execute($nick);
+ my ($root) = $get_root_nick->fetchrow_array;
+
+ return $root;
+}
+
+sub get_id_nick($) {
+ my ($id) = @_;
+
+ $get_id_nick->execute($id);
+ my ($root) = $get_id_nick->fetchrow_array;
+
+ return $root;
+}
+
+sub drop($) {
+ my ($nick) = @_;
+
+ my $ret = $drop->execute($nick);
+ $drop->finish();
+ return $ret;
+}
+
+sub changeroot($$) {
+ my ($old, $new) = @_;
+
+ return if(lc $old eq lc $new);
+
+ $change_root->execute($new, $old);
+}
+
+sub dropgroup($) {
+ my ($root) = @_;
+
+ $del_all_access->execute($root);
+ $memoserv::delete_all_memos->execute($root);
+ $memoserv::wipe_ignore->execute($root);
+ $memoserv::purge_ignore->execute($root);
+ chanserv::drop_nick_chans($root);
+ hostserv::del_vhost($root);
+ $drop_watch->execute($root);
+ $drop_silence->execute($root);
+ $drop_nicktext->execute($root);
+ $delete_aliases->execute($root);
+ $chanserv::drop_nick_akick->execute($root);
+ drop($root);
+}
+
+sub is_alias($) {
+ my ($nick) = @_;
+
+ return (get_root_nick($nick) eq $nick);
+}
+
+sub delete_alias($) {
+ my ($nick) = @_;
+ return $delete_alias->execute($nick);
+}
+
+sub delete_aliases($) {
+ my ($root) = @_;
+ return $delete_aliases->execute($root);
+}
+
+sub get_all_access($) {
+ my ($nick) = @_;
+
+ $get_all_access->execute($nick);
+ return $get_all_access->fetchrow_array;
+}
+
+sub del_all_access($) {
+ my ($root) = @_;
+
+ return $del_all_access->execute($root);
+}
+
+sub chk_pass($$$) {
+ my ($nick, $pass, $user) = @_;
+
+ if(lc($pass) eq 'force' and adminserv::can_do($user, 'SERVOP')) {
+ if(adminserv::get_best_svs_level($user) > adminserv::get_svs_level($nick)) {
+ return 1;
+ }
+ }
+
+ return validate_pass(get_pass($nick), $pass);
+}
+
+sub inc_nick_inval($) {
+ my ($user) = @_;
+ my $id = get_user_id($user);
+
+ $inc_nick_inval->execute($id);
+ $get_nick_inval->execute($id);
+ my ($nick, $inval) = $get_nick_inval->fetchrow_array;
+ if($inval > 3) {
+ ircd::irckill($nsnick, $nick, 'Too many invalid passwords.');
+ # unnecessary as irckill calls the quit handler.
+ #nick_delete($nick);
+ return 0;
+ } else {
+ return 1;
+ }
+}
+
+sub is_registered($) {
+ my ($nick) = @_;
+
+ $is_registered->execute($nick);
+ if($is_registered->fetchrow_array) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub chk_registered($;$) {
+ my ($user, $nick) = @_;
+ my $src = get_user_nick($user);
+ my $what;
+
+ if($nick) {
+ if(lc $src eq lc $nick) {
+ $what = "Your nick";
+ } else {
+ $what = "The nick \002$nick\002";
+ }
+ } else {
+ $nick = get_user_nick($user) unless $nick;
+ $what = "Your nick";
+ }
+
+ unless(is_registered($nick)) {
+ notice($user, "$what is not registered.");
+ return 0;
+ }
+
+ return 1;
+}
+
+sub is_alias_of($$) {
+ $is_alias_of->execute($_[0], $_[1]);
+ return ($is_alias_of->fetchrow_array ? 1 : 0);
+}
+
+sub check_identify($) {
+ my ($user) = @_;
+ my $nick = get_user_nick($user);
+ if(is_registered($nick)) {
+ if(is_identified($user, $nick)) {
+ ircd::setumode($nsnick, $nick, '+r');
+ $update_nickalias_last->execute($nick); $update_nickalias_last->finish();
+ return 1;
+ } else {
+ protect($nick);
+ }
+ }
+ return 0;
+}
+
+sub cleanup_users() {
+ add_timer('', services_conf_old_user_age, __PACKAGE__, 'nickserv::cleanup_users');
+ if(DEBUG) {
+ ircd::privmsg('ServServ', main_conf_diag, "Starting cleanup_users()");
+ }
+
+ my $time = (time() - (services_conf_old_user_age * 2));
+ if(DEBUG) {
+ $get_dead_users->execute($time);
+ my $arrayRef = $get_dead_users->fetchall_arrayref();
+ if($arrayRef && scalar(@$arrayRef)) {
+ ircd::privmsg('ServServ', main_conf_diag, columnar( { BORDER => 1, NOHIGHLIGHT => 1 }, @$arrayRef ) );
+ }
+ $get_dead_users->finish();
+ }
+ my $rows = $cleanup_users->execute($time) + 0;
+ $cleanup_nickid->execute();
+ $cleanup_chanuser->execute();
+ if(DEBUG) {
+ ircd::privmsg('ServServ', main_conf_diag, "Deleted $rows dead users\n");
+ ircd::privmsg('ServServ', main_conf_diag, "Ending cleanup_users()");
+ }
+}
+
+sub fix_vhosts() {
+ return; # XXX
+ add_timer('fix_vhosts', 5, __PACKAGE__, 'nickserv::fix_vhosts');
+ $get_hostless_nicks->execute();
+ while (my ($nick) = $get_hostless_nicks->fetchrow_array) {
+ ircd::notice($nsnick, main_conf_diag, "HOSTLESS NICK $nick");
+ ircd::userhost($nick);
+ ircd::userip($nick);
+ }
+ $get_hostless_nicks->finish();
+}
+
+sub nick_cede($) {
+ my ($nick) = @_;
+ my $id;
+
+ $get_user_id->execute($nick);
+ if($id = $get_user_id->fetchrow_array) {
+ $nick_id_delete->execute($id);
+ $nick_delete->execute($nick);
+ }
+}
+
+### IRC EVENTS ###
+
+sub nick_create {
+ my ($nick, $time, $ident, $host, $vhost, $server, $svsstamp, $modes, $gecos, $ip, $cloakhost) = @_;
+ my $user = { NICK => $nick };
+ get_lock($nick);
+ if ($vhost eq '*') {
+ if ({modes::splitumodes($modes)}->{x} eq '+') {
+ if(defined($cloakhost)) {
+ $vhost = $cloakhost;
+ }
+ else { # This should never happen with CLK or VHP
+ ircd::userhost($nick);
+ }
+ } else {
+ $vhost = $host;
+ }
+ }
+
+ my $id;
+ if($svsstamp) {
+ $get_user_nick->execute($svsstamp);
+ my ($oldnick) = $get_user_nick->fetchrow_array();
+ $id = $svsstamp if defined($oldnick);
+ }
+ else {
+ $nick_check->execute($nick, $time);
+ ($id) = $nick_check->fetchrow_array;
+ }
+
+ if($id) {
+ $olduser{lc $nick} = 1;
+ $nick_create_old->execute($nick, $ident, $host, $vhost, $server, $modes, $gecos, UF_FINISHED(), $cloakhost, $id);
+ } else {
+ nick_cede($nick);
+
+ my $flags = (synced() ? UF_FINISHED() : 0);
+ my $i;
+ while($i < 10 and !$nick_create->execute($nick, $time, $ident, $host, $vhost, $server, $modes, $gecos, $flags, $cloakhost)) { $i++ }
+ $id = get_user_id( { NICK => $nick } ); # There needs to be a better way to do this
+ }
+ ircd::setsvsstamp($nsnick, $nick, $id) unless $svsstamp == $id;
+
+ $add_nickchg->execute($ircline, $nick, $nick);
+
+ release_lock($nick);
+
+ $newuser{lc $nick} = 1;
+
+ if($ip) {
+ nickserv::userip(undef, $nick, $ip);
+ }
+ else { # This should never happen with NICKIP
+ ircd::userip($nick);
+ }
+
+ return $id;
+}
+
+sub nick_create_post($) {
+ my ($nick) = @_;
+ my $user = { NICK => $nick };
+ my $old = $olduser{lc $nick};
+ delete $olduser{lc $nick};
+
+ operserv::do_news($nick, 'u') unless($old);
+
+ get_lock($nick);
+
+ check_identify($user);
+
+ release_lock($nick);
+}
+
+sub nick_delete($$) {
+ my ($nick, $quit) = @_;
+ my $user = { NICK => $nick };
+
+ get_lock($nick);
+
+ my $id = get_user_id($user);
+
+ $del_nickchg_id->execute($id); $del_nickchg_id->finish();
+
+ $quit_update->execute($quit, $id); $quit_update->finish();
+ $update_lastseen->execute($id); $update_lastseen->finish();
+
+ $get_quit_empty_chans->execute($id);
+
+ $chan_user_partall->execute($id); $chan_user_partall->finish();
+ #$nick_chan_delete->execute($id); $nick_chan_delete->finish();
+ $nick_quit->execute($nick); $nick_quit->finish();
+
+ release_lock($nick);
+
+ while(my ($cn) = $get_quit_empty_chans->fetchrow_array) {
+ chanserv::channel_emptied({CHAN => $cn});
+ }
+ $get_quit_empty_chans->finish();
+}
+
+sub squit($$$) {
+ my (undef, $servers, $reason) = @_;
+
+ $get_squit_lock->execute; $get_squit_lock->finish;
+
+ foreach my $server (@$servers) {
+ $get_squit_empty_chans->execute($server);
+
+ $squit_nickreg->execute($server);
+ $squit_nickreg->finish;
+
+ $squit_lastquit->execute("Netsplit from $server", $server);
+ $squit_lastquit->finish;
+
+ $squit_users->execute($server);
+ $squit_users->finish;
+
+ while(my ($cn) = $get_squit_empty_chans->fetchrow_array) {
+ chanserv::channel_emptied({CHAN => $cn});
+ }
+ $get_squit_empty_chans->finish;
+ }
+
+ $unlock_tables->execute; $unlock_tables->finish;
+}
+
+sub nick_change($$$) {
+ my ($old, $new, $time) = @_;
+
+ return if(lc $old eq lc $new);
+
+ get_lock($old);
+ nick_cede($new);
+ $nick_change->execute($new, $time, $old);
+ $add_nickchg->execute($ircline, $new, $new);
+ release_lock($old);
+
+ if($new =~ /^guest/i) {
+ $get_guest->execute($new);
+ my ($guest) = $get_guest->fetchrow_array();
+ if($guest) {
+ $set_guest->execute(0, $new);
+ } else {
+ guestnick($new);
+ }
+ return;
+ }
+
+ ircd::setumode($nsnick, $new, '-r')
+ unless check_identify({ NICK => $new });
+}
+
+sub umode($$) {
+ my ($nick, $modes) = @_;
+ my $user = { NICK => $nick };
+
+ get_lock($nick);
+
+ my $id = get_user_id($user);
+
+ $get_umodes->execute($id);
+ my ($omodes) = $get_umodes->fetchrow_array;
+ $set_umodes->execute(modes::add($omodes, $modes, 0), $id);
+
+
+ my %modelist = modes::splitumodes($modes);
+ if (defined($modelist{x})) {
+ if($modelist{x} eq '-') {
+ my ($ident, $host) = get_host($user);
+ do_chghost(undef, $nick, $host, 1);
+ }
+ elsif(($modelist{x} eq '+') and !defined($modelist{t}) ) {
+ my (undef, $cloakhost) = get_cloakhost($user);
+ if($cloakhost) {
+ do_chghost(undef, $nick, $cloakhost, 1);
+ } else {
+ ircd::userhost($nick);
+ }
+ }
+ }
+=cut
+# awaiting resolution UnrealIRCd bug 2613
+ elsif ($modelist{t} eq '-') {
+ my %omodelist = modes::splitumodes($omodes);
+ if($omodelist{x} eq '+') {
+ my (undef, $cloakhost) = get_cloakhost($user);
+ if($cloakhost) {
+ do_chghost(undef, $nick, $cloakhost, 1);
+ } else {
+ ircd::userhost($nick);
+ }
+ }
+ }
+=cut
+ release_lock($nick);
+
+ # Else we will get it in a sethost or chghost
+ # Also be aware, our tracking of umodes xt is imperfect
+ # as the ircd doesn't always report it to us
+ # This might need fixing up in chghost()
+}
+
+sub killhandle($$$$) {
+ my ($src, $dst, $path, $reason) = @_;
+ unless (is_agent($dst)) {
+ nick_delete($dst, "Killed ($src ($reason))");
+ }
+}
+
+sub userip($$$) {
+ my($src, $nick, $ip) = @_;
+ my $is_ipv6;
+ ($is_ipv6, $ip) = is_ipv6($ip);
+ my $user = { 'NICK' => $nick };
+ my $new = $newuser{lc $nick};
+ delete $newuser{lc $nick};
+ #my $targetid = get_nick_id($target);
+ my $iip;
+ if(!$is_ipv6) {
+ my @ips = split(/\./, $ip);
+ for(my $i; $i < 4; $i++) {
+ $iip += $ips[$i] * (2 ** ((3 - $i) * 8));
+ }
+ } else {
+ $iip = Socket6::inet_pton(&AF_INET6, $ip);
+ }
+
+ get_lock($nick);
+
+ my $id = get_user_id($user);
+ if(!$is_ipv6) {
+ set_ip($user, $iip);
+ } else {
+ $iip = get_ipv6_net($ip);
+ set_ipv6($user, $iip, $ip);
+ }
+ my $killed = kill_clones($user, $iip);
+
+ release_lock($nick);
+
+ nick_create_post($nick) if(!$killed and $new);
+}
+
+sub chghost($$$) {
+ my ($src, $dst, $vhost) = @_;
+ my $user = { NICK => $dst };
+ my $uid = get_user_id($user);
+
+ get_lock($dst);
+ do_chghost($src, $dst, $vhost, 1);
+
+ $get_umodes->execute($uid);
+ my ($omodes) = $get_umodes->fetchrow_array;
+ # I'm told that this is only valid if CLK is set, and
+ # there is no good way yet to get info from the ircd/net
+ # module to this code. it stinks of ircd-specific too
+ # Also, we currently do any USERHOST replies as CHGHOST events
+ # However, that is no longer necessary with CLK
+ $set_umodes->execute(modes::add($omodes, '+xt', 0), $uid);
+ release_lock($dst);
+}
+
+sub do_chghost($$$;$) {
+# Don't use this for the handler,
+# this is only for internal use
+# where we don't want full loopback semantics.
+# We call it from the normal handler.
+ my ($src, $dst, $vhost, $no_lock) = @_;
+# $no_lock is for where we already took the lock in the caller
+# MySQL's GET LOCK doesn't allow recursive locks
+ my $user = { NICK => $dst };
+ my $uid = get_user_id($user);
+
+ $update_regnick_vhost->execute($vhost, $uid);
+ $update_regnick_vhost->finish();
+
+ get_lock($dst) unless $no_lock;
+
+ set_vhost($user, $vhost);
+ chanserv::akick_alluser($user);
+
+ release_lock($dst) unless $no_lock;
+}
+
+sub chgident($$$) {
+ my ($src, $dst, $ident) = @_;
+ my $user = { NICK => $dst };
+
+ set_ident($user, $ident);
+ chanserv::akick_alluser($user);
+}
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package operserv;
+
+use strict;
+
+use SrSv::Timer qw(add_timer);
+
+use SrSv::IRCd::State qw(get_server_state);
+use SrSv::IRCd::Validate qw( valid_server valid_nick );
+
+use SrSv::Time;
+use SrSv::Text::Format qw(columnar);
+use SrSv::Errors;
+use SrSv::Log;
+
+use SrSv::Conf2Consts qw(main services);
+
+use SrSv::User qw(get_user_nick get_user_id get_user_agent is_online get_user_info get_user_ip :flood);
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+
+use SrSv::NickReg::Flags qw(NRF_NOHIGHLIGHT nr_chk_flag_user);
+
+use SrSv::MySQL '$dbh';
+
+use SrSv::IPv6;
+
+use constant {
+ MAX_LIM => 16777215
+};
+
+*kill_user = \&nickserv::kill_user;
+
+our $osnick_default = 'OperServ';
+our $osnick = $osnick_default;
+
+my %newstypes = (
+ u => 'User',
+ o => 'Oper'
+);
+
+=cut
+ $add_akill, $del_akill, $get_all_akills, $get_expired_akills,
+ $get_akill, $check_akill,
+=cut
+
+our (
+ $add_qline, $del_qline, $get_all_qlines, $get_expired_qlines,
+ $get_qline, $check_qline,
+
+ $add_logonnews, $del_logonnews, $list_logonnews, $get_logonnews,
+ $consolidate_logonnews, $count_logonnews, $del_expired_logonnews,
+
+ $add_clone_exceptname, $add_clone_exceptserver, $add_clone_exceptip,
+ $del_clone_exceptname, $del_clone_exceptip,
+ $list_clone_exceptname, $list_clone_exceptserver, $list_clone_exceptip,
+
+ $get_clones_fromhost, $get_clones_fromnick, $get_clones_fromid, $get_clones_fromipv4,
+
+ $get_session_list,
+
+ $get_newusers, $get_newusers_noid
+);
+
+sub init() {
+=cut
+ $add_akill = $dbh->prepare("INSERT INTO akill SET setter=?, mask=?, reason=?, time=?, expire=?");
+ $del_akill = $dbh->prepare("DELETE FROM akill WHERE mask=?");
+ $get_all_akills = $dbh->prepare("SELECT setter, mask, reason, time, expire FROM akill ORDER BY time ASC");
+ $get_akill = $dbh->prepare("SELECT setter, mask, reason, time, expire FROM akill WHERE mask=?");
+ $check_akill = $dbh->prepare("SELECT 1 FROM akill WHERE mask=?");
+
+ $get_expired_akills = $dbh->prepare("SELECT setter, mask, reason, time, expire FROM akill WHERE expire < UNIX_TIMESTAMP() AND expire!=0");
+=cut
+
+ $add_qline = $dbh->prepare("INSERT INTO qline SET setter=?, mask=?, reason=?, time=?, expire=?");
+ $del_qline = $dbh->prepare("DELETE FROM qline WHERE mask=?");
+ $get_all_qlines = $dbh->prepare("SELECT setter, mask, reason, time, expire FROM qline ORDER BY time ASC");
+ $get_qline = $dbh->prepare("SELECT setter, mask, reason, time, expire FROM qline WHERE mask=?");
+ $check_qline = $dbh->prepare("SELECT 1 FROM qline WHERE mask=?");
+
+ $get_expired_qlines = $dbh->prepare("SELECT mask FROM qline WHERE expire < UNIX_TIMESTAMP() AND expire!=0");
+
+ $add_logonnews = $dbh->prepare("INSERT INTO logonnews SET setter=?, expire=?, type=?, id=?, msg=?, time=UNIX_TIMESTAMP()");
+ $del_logonnews = $dbh->prepare("DELETE FROM logonnews WHERE type=? AND id=?");
+ $list_logonnews = $dbh->prepare("SELECT setter, time, expire, id, msg FROM logonnews WHERE type=? ORDER BY id ASC");
+ $get_logonnews = $dbh->prepare("SELECT setter, time, msg FROM logonnews WHERE type=? ORDER BY id ASC");
+ $consolidate_logonnews = $dbh->prepare("UPDATE logonnews SET id=id-1 WHERE type=? AND id>?");
+ $count_logonnews = $dbh->prepare("SELECT COUNT(*) FROM logonnews WHERE type=?");
+ $del_expired_logonnews = $dbh->prepare("DELETE FROM logonnews WHERE expire < UNIX_TIMESTAMP() AND expire!=0");
+
+ $add_clone_exceptname = $dbh->prepare("REPLACE INTO sesexname SET host=?, serv=0, adder=?, lim=?");
+ $add_clone_exceptserver = $dbh->prepare("REPLACE INTO sesexname SET host=?, serv=1, adder=?, lim=?");
+ $add_clone_exceptip = $dbh->prepare("REPLACE INTO sesexip SET ip=INET_ATON(?), mask=?, adder=?, lim=?");
+
+ $del_clone_exceptname = $dbh->prepare("DELETE FROM sesexname WHERE host=?");
+ $del_clone_exceptip = $dbh->prepare("DELETE FROM sesexip WHERE ip=INET_ATON(?)");
+
+ $list_clone_exceptname = $dbh->prepare("SELECT host, adder, lim FROM sesexname WHERE serv=0 ORDER BY host ASC");
+ $list_clone_exceptserver = $dbh->prepare("SELECT host, adder, lim FROM sesexname WHERE serv=1 ORDER BY host ASC");
+ $list_clone_exceptip = $dbh->prepare("SELECT INET_NTOA(ip), mask, adder, lim FROM sesexip ORDER BY ip ASC");
+
+ $get_clones_fromhost = $dbh->prepare("SELECT user.nick, user.id, user.online
+ FROM user JOIN user AS clone ON (user.ip=clone.ip)
+ WHERE clone.host=? GROUP BY id");
+ $get_clones_fromnick = $dbh->prepare("SELECT user.nick, user.id, user.online
+ FROM user JOIN user AS clone ON (user.ip=clone.ip)
+ WHERE clone.nick=? GROUP BY id");
+ $get_clones_fromid = $dbh->prepare("SELECT user.nick, user.id, user.online
+ FROM user JOIN user AS clone ON (user.ip=clone.ip)
+ WHERE clone.id=? GROUP BY id");
+ $get_clones_fromipv4 = $dbh->prepare("SELECT user.nick, user.id, user.online
+ FROM user JOIN user AS clone ON (user.ip=clone.ip)
+ WHERE clone.ip=INET_ATON(?) GROUP BY id");
+
+ $get_session_list = $dbh->prepare("SELECT host, COUNT(*) AS c FROM user WHERE online=1 GROUP BY host HAVING c >= ?");
+
+ $get_newusers = $dbh->prepare("SELECT user.nick, user.id, user.online
+ FROM user
+ WHERE user.time > ?");
+ $get_newusers_noid = $dbh->prepare("SELECT user.nick, user.id, user.online
+ FROM user LEFT JOIN nickid ON (nickid.id=user.id)
+ WHERE nickid.id IS NULL AND user.time > ?");
+}
+
+sub dispatch($$$) {
+ my ($src, $dst, $msg) = @_;
+ $msg =~ s/^\s+//;
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ my $user = { NICK => $src, AGENT=> $dst };
+
+ services::ulog($osnick, LOG_INFO(), "cmd: [$msg]", $user);
+
+ return if flood_check($user);
+ unless(adminserv::is_svsop($user) or adminserv::is_ircop($user)) {
+ notice($user, $err_deny);
+ if($cmd =~ /^set/i) {
+ nickserv::kill_user($user, "OS SET doesn't exist here");
+ }
+ ircd::globops($osnick, "\002$src\002 failed access to $osnick $msg");
+ return;
+ }
+
+ if ($cmd =~ /^fjoin$/i) { os_fjoin($user, @args); }
+ elsif ($cmd =~ /^fpart$/i) { os_fpart($user, @args); }
+ elsif ($cmd =~ /^unidentify$/i) { os_unidentify($user, @args); }
+ elsif ($cmd =~ /^qline$/i) {
+ my $cmd2 = shift @args;
+
+ if($cmd2 =~ /^add$/i) {
+ if(@args >= 3 and $args[0] =~ /^\+/) {
+ @args = split(/\s+/, $msg, 5);
+
+ os_qline_add($user, @args[2..4]);
+ }
+ elsif(@args >= 2) {
+ @args = split(/\s+/, $msg, 4);
+
+ os_qline_add($user, 0, @args[2..3]);
+ }
+ else {
+ notice($user, 'Syntax: QLINE ADD [+expiry] <mask> <reason>');
+ }
+ }
+ elsif($cmd2 =~ /^del$/i) {
+ if(@args == 1) {
+ os_qline_del($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax: QLINE DEL <mask>');
+ }
+ }
+ elsif($cmd2 =~ /^list$/i) {
+ if(@args == 0) {
+ os_qline_list($user);
+ }
+ else {
+ notice($user, 'Syntax: QLINE LIST');
+ }
+ }
+ }
+ elsif ($cmd =~ /^jupe$/i) {
+ if(@args >= 2) {
+ os_jupe($user, shift @args, join(' ', @args));
+ }
+ else {
+ notice($user, 'Syntax: JUPE <server> <reason>');
+ }
+ }
+ elsif ($cmd =~ /^uinfo$/i) { os_uinfo($user, @args); }
+ elsif ($cmd =~ /^ninfo$/i) { os_ninfo($user, @args); }
+ elsif ($cmd =~ /^svsnick$/i) { os_svsnick($user, $args[0], $args[1]); }
+ elsif ($cmd =~ /^gnick$/i) { os_gnick($user, @args); }
+ elsif ($cmd =~ /^help$/i) { sendhelp($user, 'operserv', @args) }
+ elsif ($cmd =~ /^(staff|listadm)$/i) { adminserv::as_staff($user) }
+ elsif ($cmd =~ /^logonnews$/i) {
+ my $cmd2 = shift @args;
+
+ if($cmd2 =~ /^add$/i) {
+ if(@args >= 3 and $args[1] =~ /^\+/) {
+ @args = split(/\s+/, $msg, 5);
+
+ os_logonnews_add($user, $args[2], $args[3], $args[4]);
+ }
+ elsif(@args >= 2) {
+ @args = split(/\s+/, $msg, 4);
+
+ os_logonnews_add($user, $args[2], 0, $args[3]);
+ }
+ else {
+ notice($user, 'Syntax: LOGONNEWS ADD <type> [+expiry] <reason>');
+ }
+ }
+ elsif($cmd2 =~ /^del$/i) {
+ if(@args == 2) {
+ os_logonnews_del($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax: LOGONNEWS DEL <type> <id>');
+ }
+ }
+ elsif($cmd2 =~ /^list$/i) {
+ if(@args == 1) {
+ os_logonnews_list($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax: LOGONNEWS LIST <type>');
+ }
+ }
+ else {
+ notice($user, 'Syntax: LOGONNEWS <LIST|ADD|DEL> <type>');
+ }
+ }
+ elsif($cmd =~ /^except(ion)?$/i) {
+ my $cmd2 = shift @args;
+ if($cmd2 =~ /^server$/i) {
+ my $cmd3 = shift @args;
+ if($cmd3 =~ /^a(dd)?$/) {
+ if(@args == 2) {
+ os_except_server_add($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT SERVER ADD <hostname> <limit>');
+ }
+ }
+ elsif($cmd =~ /^d(el)?$/) {
+ if(@args == 1) {
+ os_except_server_del($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT SERVER DEL <hostname>');
+ }
+ }
+ else {
+ notice($user, 'Syntax EXCEPT SERVER <ADD|DEL>');
+ }
+ }
+ elsif($cmd2 =~ /^h(ostname)?$/i) {
+ my $cmd3 = shift @args;
+ if($cmd3 =~ /^a(dd)?$/) {
+ if(@args == 2) {
+ os_except_hostname_add($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT HOSTNAME ADD <hostname> <limit>');
+ }
+ }
+ elsif($cmd3 =~ /^d(el)?$/) {
+ if(@args == 1) {
+ os_except_hostname_del($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT HOSTNAME DEL <hostname>');
+ }
+ }
+ else {
+ notice($user, 'Syntax EXCEPT HOSTNAME <ADD|DEL>');
+ }
+ }
+ elsif($cmd2 =~ /^i(p)?$/i) {
+ my $cmd3 = shift @args;
+ if($cmd3 =~ /^a(dd)?$/) {
+ if(@args == 2) {
+ os_except_IP_add($user, $args[0], $args[1]);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT IP ADD <IP/mask> <limit>');
+ }
+ }
+ elsif($cmd3 =~ /^d(el)?$/) {
+ if(@args == 1) {
+ os_except_IP_del($user, $args[0]);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT IP DEL <IP>');
+ }
+ }
+ else {
+ notice($user, 'Syntax EXCEPT IP <ADD|DEL>');
+ }
+ }
+ elsif($cmd2 =~ /^l(ist)?$/i) {
+ if(@args == 0) {
+ os_except_list($user);
+ }
+ else {
+ notice($user, 'Syntax EXCEPT LIST');
+ }
+ }
+ else {
+ notice($user, 'Syntax: EXCEPT <SERVER|HOSTNAME|IP|LIST>');
+ }
+ }
+ elsif($cmd =~ /^session$/i) {
+ if(@args == 1) {
+ os_session_list($user, $args[0]);
+ } else {
+ notice($user, 'Syntax SESSION <lim>');
+ }
+ }
+ elsif($cmd =~ /^chankill$/i) {
+ if(@args >= 2) {
+ (undef, @args) = split(/\s+/, $msg, 3);
+ os_chankill($user, @args);
+ } else {
+ notice($user, 'Syntax: CHANKILL <#chan> <reason>');
+ }
+ }
+ elsif ($cmd =~ /^rehash$/i) {
+ if(@args <= 1) {
+ os_rehash($user, @args);
+ }
+ else {
+ notice($user, 'Syntax: REHASH [type]');
+ }
+ }
+ elsif ($cmd =~ /^loners$/i) {
+ os_loners($user, @args);
+ }
+ elsif($cmd =~ /^svskill$/i) {
+ if(@args >= 2) {
+ os_svskill($user, shift @args, join(' ', @args));
+ }
+ else {
+ notice($user, 'Syntax SVSKILL <target> <reason here>');
+ }
+ }
+ elsif($cmd =~ /^kill$/i) {
+ if(@args >= 1) {
+ os_kill($user, shift @args, join(' ', @args));
+ }
+ else {
+ notice($user, 'Syntax KILL <target> <reason here>');
+ }
+ }
+ elsif ($cmd =~ /^clones$/i) {
+ os_clones($user, @args);
+ }
+ elsif ($cmd =~ /^m(ass)?kill$/i) {
+ os_clones($user, 'KILL', @args);
+ }
+ elsif($cmd =~ /^(kline|gline)$/i) {
+ if(@args >= 1) {
+ os_gline($user, 0, @args);
+ }
+ else {
+ notice($user, 'Syntax GLINE <target> [+time] [reason here]');
+ }
+ }
+ elsif($cmd =~ /^(zline|gzline)$/i) {
+ if(@args >= 1) {
+ os_gline($user, 1, @args);
+ }
+ else {
+ notice($user, 'Syntax GZLINE <target> [+time] [reason here]');
+ }
+ }
+ elsif ($cmd =~ /^killnew$/i) {
+ os_killnew($user, @args);
+ }
+
+ else { notice($user, "Unknown command."); }
+}
+
+sub os_fjoin($$@) {
+ my ($user, $target, @chans) = @_;
+ if ((!$target or !@chans) or !($chans[0] =~ /^#/)) {
+ notice($user, "Syntax: /OS FJOIN <nick> <#channel1> [#channel2]");
+ }
+ unless (is_online($target)) {
+ notice($user, "\002$target\002 is not online");
+ return;
+ }
+
+ if (!adminserv::can_do($user, 'FJOIN')) {
+ notice($user, "You don't have the right access");
+ return $event::SUCCESS;
+ }
+ ircd::svsjoin($osnick, $target, @chans);
+}
+
+sub os_fpart($$@) {
+ my ($user, $target, @params) = @_;
+ if ((!$target or !@params) or !($params[0] =~ /^#/)) {
+ notice($user, "Syntax: /OS FPART <nick> <#channel1> [#channel2] [reason]");
+ }
+ unless (is_online($target)) {
+ notice($user, "\002$target\002 is not online");
+ return;
+ }
+
+ if (!adminserv::can_do($user, 'FJOIN')) {
+ notice($user, "You don't have the right access");
+ return $event::SUCCESS;
+ }
+
+ my ($reason, @chans);
+ while ($params[0] =~ /^#/) {
+ push @chans, shift @params;
+ }
+ $reason = join(' ', @params) if @params;
+
+ ircd::svspart($osnick, $target, $reason, @chans);
+}
+
+sub os_qline_add($$$$) {
+ my ($user, $expiry, $mask, $reason) = @_;
+
+ chk_auth($user, 'QLINE') or return;
+
+ $expiry = parse_time($expiry);
+ if($expiry) { $expiry += time() }
+ else { $expiry = 0 }
+
+ $check_qline->execute($mask);
+ if ($check_qline->fetchrow_array) {
+ notice($user, "$mask is already qlined");
+ return $event::SUCCESS;
+ } else {
+ my $src = get_user_nick($user);
+ $add_qline->execute($src, $mask, $reason, time(), $expiry);
+ ircd::sqline($mask, $reason);
+ notice($user, "$mask is now Q:lined");
+ }
+}
+
+sub os_qline_del($$) {
+ my($user, $mask) = @_;
+
+ chk_auth($user, 'QLINE') or return;
+
+ $check_qline->execute($mask);
+ if($check_qline->fetchrow_array) {
+ $del_qline->execute($mask);
+ ircd::unsqline($mask);
+ notice($user, "$mask unqlined");
+ } else {
+ notice($user, "$mask is not qlined");
+ }
+}
+
+sub os_qline_list($) {
+ my ($user) = @_;
+ my (@reply);
+
+ chk_auth($user, 'QLINE') or return;
+
+ push @reply, 'Q:line list:';
+
+ $get_all_qlines->execute();
+ my $i;
+ while (my ($setter, $mask, $reason, $time, $expiry) = $get_all_qlines->fetchrow_array) {
+ $i++;
+ my $akill_entry1 = " $i) \002$mask\002 $reason";
+ my $akill_entry2 = " set by $setter on ".gmtime2($time).'; ';
+ if($expiry) {
+ my ($weeks, $days, $hours, $minutes, $seconds) = split_time($expiry-time());
+ $akill_entry2 .= "Expires in ".($weeks?"$weeks weeks ":'').
+ ($days?"$days days ":'').
+ ($hours?"$hours hours ":'').
+ ($minutes?"$minutes minutes ":'');
+ }
+ else {
+ $akill_entry2 .= "Does not expire.";
+ }
+ push @reply, $akill_entry1; push @reply, $akill_entry2;
+ }
+ $get_all_qlines->finish();
+ push @reply, ' --';
+
+ notice($user, @reply) if @reply;
+}
+
+sub os_jupe($$$) {
+ # introduces fake server to network.
+ my ($user, $server, $reason) = @_;
+
+ unless (adminserv::is_svsop($user, adminserv::S_ROOT())) {
+ notice($user, $err_deny);
+ return $event::SUCCESS;
+ }
+ unless (valid_server($server)) {
+ notice($user, "$server is not a valid servername.");
+ return $event::SUCCESS;
+ }
+ if (get_server_state($server)) {
+ notice($user, "$server is currently connected. You must SQUIT before using JUPE.");
+ return $event::SUCCESS;
+ }
+
+ ircd::jupe_server($server, "Juped by ".get_user_nick($user).": $reason");
+ notice($user, "$server is now juped.");
+ return $event::SUCCESS;
+}
+
+sub os_unidentify($$) {
+ my ($user, $tnick) = @_;
+
+ my $tuser = { NICK => $tnick };
+ my $tuid;
+
+ unless ($tuid = get_user_id($tuser)) {
+ notice($user, "\002$tnick\002 is not online");
+ }
+ unless (adminserv::can_do($user, 'SERVOP')) {
+ notice($user, $err_deny);
+ }
+ $nickserv::logout->execute($tuid);
+ notice($user, "$tnick logged out from all nick identifies");
+}
+
+sub os_uinfo($@) {
+ my ($user, @targets) = @_;
+
+ my @userlist;
+ my @reply;
+ foreach my $target (@targets) {
+ if(ref($target)) {
+ push @userlist, $target;
+ next;
+ }
+ if($target =~ /\,/) {
+ push @targets, split(',', $target);
+ next;
+ }
+ my @data;
+ my $tuser = { NICK => $target };
+ my $tuid = get_user_id($tuser);
+ unless ($tuid) {
+ push @reply, "\002$target\002: user not found";
+ next;
+ }
+ push @userlist, $tuser;
+ }
+ @targets = (); # drop this list now.
+
+ notice($user, @reply, get_uinfo($user, @userlist));
+ return $event::SUCCESS;
+}
+
+sub os_ninfo($@) {
+ my ($user, @targetsIn) = @_;
+
+ my (@targetsOut, @reply);
+ foreach my $target (@targetsIn) {
+ if(not nickserv::is_registered($target)) {
+ push @reply, "\002$target\002: is not registered.";
+ }
+ my @targets = SrSv::NickReg::User::get_nick_users_all($target);
+ if(scalar(@targets) == 0) {
+ push @reply, "\002$target\002: no user[s] online.";
+ next;
+ }
+ push @targetsOut, @targets;
+ }
+ @targetsIn = (); # drop this list now.
+ notice($user, @reply) if scalar(@reply);
+ if(scalar(@targetsOut)) {
+ return os_uinfo($user, @targetsOut);
+ }
+ return $event::SUCCESS;
+}
+
+sub os_svsnick($$$) {
+ my ($user, $curnick, $newnick) = @_;
+ my $tuser = { NICK => $curnick };
+
+ if(!adminserv::is_svsop($user, adminserv::S_ROOT())) {
+ notice($user, $err_deny);
+ return $event::SUCCESS;
+ }
+ if ((!$curnick) or (!$newnick)) {
+ notice($user, "Syntax: SVSNICK <curnick> <newnick>");
+ return $event::SUCCESS;
+ }
+ if (!is_online($tuser)) {
+ notice($user, $curnick.' is not online.');
+ return $event::SUCCESS;
+ }
+ if (nickserv::is_online($newnick)) {
+ notice($user, $newnick.' already exists.');
+ return $event::SUCCESS;
+ }
+ nickserv::enforcer_quit($newnick);
+ ircd::svsnick($osnick, $curnick, $newnick);
+ notice($user, $curnick.' changed to '.$newnick);
+ return $event::SUCCESS;
+}
+
+sub os_gnick($@) {
+ my ($user, @targets) = @_;
+
+ if(!adminserv::can_do($user, 'QLINE')) {
+ notice($user, $err_deny);
+ return $event::SUCCESS;
+ }
+ if (@targets == 0) {
+ notice($user, "Syntax: GNICK <nick>");
+ return $event::SUCCESS;
+ }
+ foreach my $target (@targets) {
+ if (!is_online($target)) {
+ notice($user, $target.' is not online.');
+ next;
+ }
+ my $newnick = nickserv::collide($target);
+ notice($user, $target.' changed to '.$newnick);
+ }
+ return $event::SUCCESS;
+}
+
+sub os_logonnews_pre($$) {
+ my ($user, $type) = @_;
+
+ unless(adminserv::is_svsop($user, adminserv::S_ADMIN())) {
+ notice($user, $err_deny);
+ return undef;
+ }
+
+ return 'u' if($type =~ /^(user)|(u)$/i);
+ return 'o' if($type =~ /^(oper)|(o)$/i);
+ notice($user, 'invalid LOGONNEWS <type>');
+ return undef;
+}
+
+sub os_logonnews_add($$$) {
+ my ($user, $type, $expiry, $msg) = @_;
+
+ return unless ($type = os_logonnews_pre($user, $type));
+
+ my $mlength = length($msg);
+ if($mlength >= 350) {
+ notice($user, 'Message is too long by '. $mlength-350 .' character(s). Maximum length is 350 chars');
+ return;
+ }
+
+ if($expiry) {
+ $expiry = parse_time($expiry);
+ }
+ else {
+ $expiry = 0;
+ }
+
+ my $src = get_user_nick($user);
+ $count_logonnews->execute($type);
+ my $count = $count_logonnews->fetchrow_array;
+
+ $add_logonnews->execute($src, $expiry ? time()+$expiry : 0, $type, ++$count, $msg);
+
+ notice($user, "Added new $newstypes{$type} News #\002$count\002");
+}
+
+sub os_logonnews_del($$$) {
+ my ($user, $type, $id) = @_;
+
+ return unless ($type = os_logonnews_pre($user, $type));
+
+ my $ret = $del_logonnews->execute($type, $id);
+
+ if ($ret == 1) {
+ notice($user, "News Item $newstypes{$type} News #\002$id\002 deleted");
+ $consolidate_logonnews->execute($type, $id);
+ }
+ else {
+ notice($user, "Delete of $newstypes{$type} News #\002$id\002 failed.",
+ "$newstypes{$type} #\002$id\002 does not exist?");
+ }
+}
+
+sub os_logonnews_list($$) {
+ my ($user, $type) = @_;
+
+ return unless ($type = os_logonnews_pre($user, $type));
+
+ my @reply;
+ push @reply, "\002$newstypes{$type}\002 News";
+
+ $list_logonnews->execute($type);
+ push @reply, "There is no $newstypes{$type} News"
+ unless($list_logonnews->rows);
+ while(my ($adder, $time, $expiry, $id, $msg) = $list_logonnews->fetchrow_array) {
+ my ($weeks, $days, $hours, $minutes, $seconds) = split_time($expiry-time());
+ my $expire_string = ($expiry?"Expires in ".($weeks?"$weeks weeks ":'').
+ ($days?"$days days ":'').
+ ($hours?"$hours hours ":'').
+ ($minutes?"$minutes minutes ":'')
+ :'Does not expire');
+ push @reply, "$id\) $msg";
+ push @reply, join(' ', '', 'added: '.gmtime2($time), $expire_string, "added by: $adder");
+ }
+ $list_logonnews->finish();
+ notice($user, @reply);
+}
+
+sub os_except_pre($) {
+ my ($user) = @_;
+
+ if (adminserv::is_svsop($user, adminserv::S_ADMIN()) ) {
+ return 1;
+ }
+ else {
+ notice($user, $err_deny);
+ return 0;
+ }
+}
+
+sub os_except_hostname_add($$$) {
+ my ($user, $hostname, $limit) = @_;
+
+ os_except_pre($user) or return 0;
+
+ if ($hostname =~ m/\@/ or not $hostname =~ /\./) {
+ notice($user, 'Invalid hostmask.', 'A clone exception hostmask is the HOST portion only, no ident',
+ 'and must contain at least one dot \'.\'');
+ return;
+ }
+
+ $limit = MAX_LIM() unless $limit;
+
+ my $src = get_user_nick($user);
+ my $hostmask = $hostname;
+ $hostmask =~ s/\*/\%/g;
+ $add_clone_exceptname->execute($hostmask, $src, $limit);
+ notice($user, "Clone exception for host \002$hostname\002 added.");
+}
+
+sub os_except_server_add($$$) {
+ my ($user, $hostname, $limit) = @_;
+
+ os_except_pre($user) or return 0;
+
+ if ($hostname =~ m/\@/ or not $hostname =~ /\./) {
+ notice($user, 'Invalid hostmask.', 'A clone exception servername has no ident',
+ 'and must contain at least one dot \'.\'');
+ return;
+ }
+
+ $limit = MAX_LIM() unless $limit;
+
+ my $src = get_user_nick($user);
+ my $hostmask = $hostname;
+ $hostmask =~ s/\*/\%/g;
+ $add_clone_exceptserver->execute($hostmask, $src, $limit);
+ notice($user, "Clone exception for server \002$hostname\002 added.");
+}
+
+sub os_except_IP_add($$$$) {
+ my ($user, $IP, $limit) = @_;
+
+ os_except_pre($user) or return 0;
+
+ my $mask;
+ ($IP, $mask) = split(/\//, $IP);
+ $mask = 32 unless $mask;
+ if ($IP =~ m/\@/ or not $IP =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/) {
+ notice($user, 'Invalid hostmask.', 'A clone exception IP has no ident',
+ 'and must be a valid IP address with 4 octets (example: 1.2.3.4)');
+ return;
+ }
+
+ $limit = MAX_LIM() unless $limit;
+
+ my $src = get_user_nick($user);
+ $add_clone_exceptip->execute($IP, $mask, $src, $limit);
+ notice($user, "IP clone exception \002$IP\/$mask\002 added.");
+}
+
+sub os_except_hostname_del($$) {
+ my ($user, $hostname) = @_;
+
+ os_except_pre($user) or return 0;
+
+ my $hostmask = $hostname;
+ $hostmask =~ s/\*/\%/g;
+ my $ret = $del_clone_exceptname->execute($hostmask);
+ ircd::notice($osnick, main_conf_diag, "hostname: $hostname; hostmask: $hostmask");
+
+ if($ret == 1) {
+ notice($user, "\002$hostname\002 successfully deleted from the hostname exception list");
+ }
+ else {
+ notice($user, "Deletion of \002$hostname\002 \037failed\037. \002$hostname\002 entry does not exist?");
+ }
+}
+
+sub os_except_server_del($$) {
+ my ($user, $hostname) = @_;
+
+ os_except_pre($user) or return 0;
+
+ my $hostmask = $hostname;
+ $hostmask =~ s/\*/\%/g;
+ my $ret = $del_clone_exceptname->execute($hostmask);
+
+ if($ret == 1) {
+ notice($user, "\002$hostname\002 successfully deleted from the server exception list");
+ }
+ else {
+ notice($user, "Deletion of \002$hostname\002 \037failed\037. \002$hostname\002 entry does not exist?");
+ }
+}
+
+sub os_except_IP_del($$$) {
+ my ($user, $IP) = @_;
+
+ os_except_pre($user) or return 0;
+
+ no warnings 'misc';
+ my ($IP, $mask) = split(/\//, $IP);
+ $mask = 32 unless $mask;
+ my $ret = $del_clone_exceptip->execute($IP);
+
+ if($ret == 1) {
+ notice($user, "\002$IP/$mask\002 successfully deleted from the IP exception list");
+ }
+ else {
+ notice($user, "Deletion of \002$IP/$mask\002 \037failed\037. \002$IP/$mask\002 entry does not exist?");
+ }
+}
+
+sub os_except_list($) {
+ my ($user) = @_;
+ my @data;
+
+ $list_clone_exceptserver->execute();
+ while(my ($host, $adder, $lim) = $list_clone_exceptserver->fetchrow_array) {
+ $host =~ s/\%/\*/g;
+ push @data, ['Server:', $host, $lim!=MAX_LIM()?$lim:'unlimited', "($adder)"];
+ }
+
+ $list_clone_exceptname->execute();
+ while(my ($host, $adder, $lim) = $list_clone_exceptname->fetchrow_array) {
+ $host =~ s/\%/\*/g;
+ push @data, ['Host:', $host, $lim!=MAX_LIM()?$lim:'unlimited', "($adder)"];
+ }
+
+ $list_clone_exceptip->execute();
+ while(my ($ip, $mask, $adder, $lim) = $list_clone_exceptip->fetchrow_array) {
+ push @data, ['IP:', "$ip/$mask", $lim!=MAX_LIM()?$lim:'unlimited', "($adder)"];
+ }
+
+ notice($user, columnar {TITLE => "Clone exception list:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+}
+
+sub os_session_list($) {
+ my ($user, $lim) = @_;
+
+ unless($lim > 1) {
+ notice($user, "Please specify a number greater than 1.");
+ return;
+ }
+
+ $get_session_list->execute($lim);
+ my $data = $get_session_list->fetchall_arrayref;
+
+ notice($user, columnar {TITLE => "Hosts with at least $lim sessions:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @$data);
+}
+
+sub os_chankill($$$) {
+ my ($user, $cn, $reason) = @_;
+
+ unless(adminserv::is_svsop($user, adminserv::S_OPER())) {
+ notice($user, $err_deny);
+ return;
+ }
+ my $src = get_user_nick($user);
+
+ chanserv::chan_kill({ CHAN => $cn }, "$reason ($src - ".gmtime2(time()).")");
+}
+
+sub os_rehash($;$) {
+ my ($user, $type) = @_;
+
+ unless (adminserv::is_svsop($user, adminserv::S_ROOT())) {
+ notice($user, $err_deny);
+ return $event::SUCCESS;
+ }
+
+ ircd::rehash_all_servers($type);
+ return $event::SUCCESS;
+}
+
+
+sub os_svskill($$$) {
+ my ($user, $targets, $reason) = @_;
+
+
+ if(!adminserv::is_svsop($user, adminserv::S_ROOT())) {
+ notice($user, $err_deny);
+ return $event::SUCCESS;
+ }
+
+ foreach my $target (split(',', $targets)) {
+ #my $tuser = { NICK => $target };
+ if (!is_online({ NICK => $target })) {
+ notice($user, $target.' is not online.');
+ return $event::SUCCESS;
+ }
+
+ ircd::svskill($osnick, $target, $reason);
+ }
+
+ return $event::SUCCESS;
+}
+
+sub os_kill($$$) {
+ my ($user, $targets, $reason) = @_;
+
+
+ if(!adminserv::can_do($user, 'KILL')) {
+ notice($user, $err_deny);
+ return $event::SUCCESS;
+ }
+
+ foreach my $target (split(',', $targets)) {
+ my $tuser = { NICK => $target, AGENT => $osnick };
+ if (!get_user_id($tuser)) {
+ notice($user, $target.' is not online.');
+ return $event::SUCCESS;
+ }
+
+ nickserv::kill_user($tuser, "Killed by ".get_user_nick($user).($reason ? ': '.$reason : ''));
+ }
+
+}
+
+sub os_gline($$$@) {
+ my ($user, $zline, $target, @args) = @_;
+
+ my $opernick;
+ return unless ($opernick = adminserv::is_svsop($user, adminserv::S_OPER));
+
+ my $expiry;
+ $expiry = parse_time(shift @args) if $args[0] =~ /^\+/;
+ my $reason = join(' ', @args);
+ $reason =~ s/^\:// if $reason;
+ my $remove;
+ if($target =~ /^-/) {
+ $remove = 1;
+ $target =~ s/^-//;
+ }
+
+ my ($ident, $host);
+ if($target =~ /\!/) {
+ notice($user, "Invalid G:line target \002$target\002");
+ return;
+ }
+ elsif($target =~ /^(\S+)\@(\S+)$/) {
+ ($ident, $host) = ($1, $2);
+ } elsif($target =~ /\./) {
+ ($ident, $host) = ('*', $target);
+ } elsif(valid_nick($target)) {
+ my $tuser = { NICK => $target };
+ unless(get_user_id($tuser)) {
+ notice($user, "Unknown user \002$target\002");
+ return;
+ }
+ unless($zline) {
+ (undef, $host) = nickserv::get_host($tuser);
+ $ident = '*';
+ } else {
+ $host = get_user_ip($tuser);
+ if ($host =~ /:/) {
+ $host = get_ipv6_64($host);
+ }
+ }
+ } else {
+ notice($user, "Invalid G:line target \002$target\002");
+ return;
+ }
+ unless($zline) {
+ if(!$remove) {
+ ircd::kline($opernick, $ident, $host, $expiry, $reason);
+ } else {
+ ircd::unkline($opernick, $ident, $host);
+ }
+
+ } else {
+ if($ident and $ident !~ /^\**$/) {
+ notice($user, "You cannot specify an ident in a Z:line");
+ }
+ elsif ($host =~ /^(?:\d{1,3}\.){3}(?:\d{1,3})/) {
+ # all is well, do nothing
+ }
+ elsif ($host =~ /^[0-9\/\*\?\.]+$/) {
+ # This may allow invalid CIDR, not sure.
+ # We're trusting our opers to not do stupid things.
+ # THIS MAY BE A SOURCE OF BUGS.
+
+ # all is well, do nothing
+ } elsif($host =~ /:/) {
+ #validating IPv6 addrs without using inet_pton and inet_ntop is a crapshoot
+ # for now, we do nothing.
+ } else {
+ notice($user, "Z:lines can only be placed on IPs or IP ranges");
+ return;
+ }
+ if(!$remove) {
+ ircd::zline($opernick, $host, $expiry, $reason);
+ } else {
+ ircd::unzline($opernick, $host);
+ }
+ }
+
+ return $event::SUCCESS;
+}
+
+sub os_loners($@) {
+ my ($user, @args) = @_;
+ my $cmd = shift @args;
+ my $noid;
+ if ($cmd =~ /(not?id|noidentify)/) {
+ $noid = 1;
+ $cmd = shift @args;
+ }
+ if (defined($args[0]) and $args[0] =~ /(not?id|noidentify)/) {
+ $noid = 1;
+ shift @args;
+ }
+
+ return __os_massmod($user, uc 'clones', $cmd, \&chanserv::get_users_nochans, $noid, @args);
+}
+sub os_clones($@) {
+ my ($user, @args) = @_;
+ my $cmd = shift @args;
+ my $target = shift @args;
+
+ return __os_massmod($user, 'Clones', $cmd, \&get_clones, $target, @args);
+}
+
+sub os_killnew($@) {
+ my ($user, @args) = @_;
+ my $cmd = shift @args;
+
+ my ($noid, $time);
+ if ($cmd =~ /(not?id|noidentify)/) {
+ $noid = 1;
+ $cmd = shift @args;
+ }
+ if (defined($args[0]) and $args[0] =~ /(not?id|noidentify)/) {
+ $noid = 1;
+ shift @args;
+ }
+ if(defined($args[0] and $args[0] =~ /^\+/)) {
+ $time = parse_time(shift @args);
+ }
+
+ return __os_massmod($user, 'killnew', $cmd, \&get_newusers, [$noid, $time], @args);
+}
+
+sub __os_massmod($$$$@) {
+ my ($user, $cmd0, $cmd1, $func, $arg, @args) = @_;
+ my $msg = join(' ', @args);
+
+ if($cmd1 =~ /^list$/i) {
+ my @data;
+ my $noun;
+ foreach my $tuser (&$func($arg)) {
+ push @data, [get_user_nick($tuser), (is_online($tuser) ? "\002Online\002" : "\002Offline\002")];
+ }
+ my $title;
+ if($cmd0 eq 'Clones') {
+ $title = "$cmd0 matching \002$arg\002";
+ } elsif($cmd0 eq 'Loners') {
+ $title = "$cmd0 ".($arg ? 'Not identified' : '');
+ } elsif($cmd0 eq 'Loners') {
+ $title = "New users ".($arg ? 'Not identified' : '');
+ }
+ notice($user, columnar {TITLE => $title,
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data);
+ }
+ elsif($cmd1 =~ /^uinfo$/i) {
+ notice($user, get_uinfo($user, &$func($arg)));
+ }
+ elsif($cmd1 =~ /^kill$/i) {
+ unless(adminserv::can_do($user, 'KILL')) {
+ notice($user, $err_deny);
+ return;
+ }
+ foreach my $tuser (&$func($arg)) {
+ next unless is_online($tuser);
+ $tuser->{AGENT} = $osnick;
+ nickserv::kill_user($tuser,
+ "Killed by \002".get_user_nick($user)."\002".
+ ($msg ? ": $msg" : '')
+ );
+ }
+ }
+ elsif($cmd1 =~ /^kline$/i) {
+ unless(adminserv::is_svsop($user, adminserv::S_OPER())) {
+ notice($user, $err_deny);
+ return;
+ }
+ foreach my $tuser (&$func($arg)) {
+ next unless is_online($tuser);
+ $tuser->{AGENT} = $osnick;
+ nickserv::kline_user($tuser, services_conf_chankilltime,
+ "K:Lined by \002".get_user_nick($user)."\002".
+ ($msg ? ": $msg" : '')
+ );
+ }
+ }
+ elsif($cmd1 =~ /^(msg|message|notice)$/i) {
+ notice($user, "Must have message to send") unless(@args);
+ foreach my $tuser (&$func($arg)) {
+ next unless is_online($tuser);
+ $tuser->{AGENT} = $osnick;
+ notice($tuser,
+ "Automated message from \002".get_user_nick($user),
+ $msg
+ );
+ }
+ }
+ elsif($cmd1 =~ /^fjoin$/i) {
+ unless(adminserv::can_do($user, 'FJOIN')) {
+ notice($user, $err_deny);
+ return;
+ }
+
+ if ($args[0] !~ /^#/) {
+ notice($user, "\002".$args[0]."\002 is not a valid channel name");
+ return;
+ }
+
+ foreach my $tuser (&$func($arg)) {
+ next unless is_online($tuser);
+ my $cn = $msg; # not a message, most cases it is
+ $tuser->{AGENT} = $osnick;
+ ircd::svsjoin($osnick, get_user_nick($tuser), $cn);
+ }
+ }
+ else {
+ notice($user, "Unknown $cmd0 command: $cmd1",
+ "Syntax: OS $cmd0 [LIST|UINFO|MSG|FJOIN|KILL|KLINE] [msg/reason]");
+ }
+}
+
+### MISCELLANEA ###
+
+sub do_news($$) {
+ my ($nick, $type) = @_;
+
+ my ($banner, @reply);
+
+ if ($type eq 'u') {
+ $banner = "\002Logon News\002";
+ }
+ elsif ($type eq 'o') {
+ $banner = "\002Oper News\002";
+ }
+ $get_logonnews->execute($type);
+ while(my ($adder, $time, $msg) = $get_logonnews->fetchrow_array) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
+ $year += 1900;
+ push @reply, "[$banner ".$months[$mon]." $mday $year] $msg";
+ }
+ $get_logonnews->finish();
+ ircd::notice(main_conf_local, $nick, @reply) if scalar(@reply);
+}
+
+sub chk_auth($$) {
+ my ($user, $perm) = @_;
+
+ if(adminserv::can_do($user, $perm)) {
+ return 1;
+ }
+
+ notice($user, $err_deny);
+ return 0;
+}
+
+sub expire(;$) {
+ add_timer('OperServ Expire', 60, __PACKAGE__, 'operserv::expire');
+
+ $get_expired_qlines->execute();
+ while (my ($mask) = $get_expired_qlines->fetchrow_array() ) {
+ ircd::unsqline($mask);
+ $del_qline->execute($mask);
+ }
+ $get_expired_qlines->finish();
+
+ #don't run this code yet.
+=cut
+ $get_expired_akills->execute();
+ while (my ($mask) = $get_expired_akills->fetchrow_array() ) {
+ ($ident, $host) = split('@', $mask);
+ ircd::unkline($osnick, $ident, $host);
+ $del_akill->execute($mask);
+ }
+ $get_expired_akills->finish();
+=cut
+
+ $del_expired_logonnews->execute();
+}
+
+sub get_uinfo($@) {
+ my ($user, @userlist) = @_;
+ my @reply;
+ foreach my $tuser (@userlist) {
+ my ($ident, $host, $vhost, $gecos, $server, $signontime, $quittime) = get_user_info($tuser);
+ my $modes = nickserv::get_user_modes($tuser);
+ my $target = get_user_nick($tuser);
+
+ my ($curchans, $oldchans) = chanserv::get_user_chans_recent($tuser);
+
+ my @data = (
+ ["Status:", (nickserv::is_online($tuser) ?
+ "Online (".gmtime2($signontime).')' :
+ "Offline (".gmtime2($quittime).')'
+ )
+ ],
+ ["ID Nicks:", join(', ', nickserv::get_id_nicks($tuser))],
+ ["Channels:", join(', ', @$curchans)],
+ ["Recently Parted:", join(', ', @$oldchans)],
+ ["Flood level:", get_flood_level($tuser)],
+ ["Hostmask:", "$target\!$ident\@$vhost"],
+ ["GECOS:", $gecos],
+ ["Connecting from:", "$host"],
+ ["Current Server:", $server],
+ ["Modes:", $modes]
+ );
+ if(module::is_loaded('country')) {
+ push @data, ["Country:", country::get_user_country_long($tuser)];
+ } elsif(module::is_loaded('geoip')) {
+ push @data, ["Location:", geoip::stringify_location(geoip::get_user_location($tuser))];
+ }
+
+ push @reply, columnar {TITLE => "User info for \002$target\002:",
+ NOHIGHLIGHT => nr_chk_flag_user($user, NRF_NOHIGHLIGHT)}, @data;
+ }
+ return @reply;
+}
+
+sub get_clones($) {
+ my ($targets) = @_;
+ my @users;
+ foreach my $target (split(',', $targets)) {
+ my $sth; # statement handle. You'll see what I'll do with it next!
+ if($target =~ /^(?:\d{1,3}\.){3}\d{1,3}$/) {
+ $sth = $get_clones_fromipv4;
+ } elsif($target =~ /\./) { # doesn't really work with localhost. oh well.
+ $sth = $get_clones_fromhost;
+ } else {
+ $sth = $get_clones_fromnick;
+ }
+
+ $sth->execute($target);
+ while(my ($nick, $id, $online) = $sth->fetchrow_array()) {
+ push @users, { NICK => $nick, ID => $id, ONLINE => $online };
+ }
+ $sth->finish();
+ }
+ return @users;
+}
+
+sub get_newusers($) {
+ my ($noid, $time) = @{$_[0]};
+ ircd::debug("get_newusers: $time");
+ my @users;
+ my $sth; # statement handle. You'll see what I'll do with it next!
+ if($noid) {
+ $sth = $get_newusers_noid;
+ } else {
+ $sth = $get_newusers;
+ }
+
+ $sth->execute(CORE::time()-$time);
+ while(my ($nick, $id, $online) = $sth->fetchrow_array()) {
+ push @users, { NICK => $nick, ID => $id, ONLINE => $online };
+ }
+ $sth->finish();
+ return @users;
+}
+
+## IRC EVENTS ##
+
+1;
--- /dev/null
+package spamserv;
+
+use strict;
+use Storable;
+
+use SrSv::MySQL '$dbh';
+use SrSv::Timer qw(add_timer);
+use SrSv::IRCd::Event qw( addhandler );
+use SrSv::Agent;
+use SrSv::Conf2Consts qw( main services );
+use SrSv::Shared qw($fakehost %conf $idlelength);
+use SrSv::User::Notice;
+use SrSv::Help qw( sendhelp );
+use SrSv::SimpleHash qw(readHash writeHash);
+
+my $ssnick = 'SpamServ';
+my %chanlist;
+
+use SrSv::Process::InParent qw(list_conf loadconf loadchans saveconf savechans);
+
+# should load both spamserv.conf and chans.conf (if available)
+loadconf();
+loadchans();
+
+addhandler('PRIVMSG', undef, undef, 'spamserv::ss_privmsg');
+addhandler('NOTICE', undef, undef, 'spamserv::ss_notice');
+
+agent_connect($ssnick, 'services', undef, '+pqzBGHS', 'Spam Serv');
+agent_join($ssnick, main_conf_diag);
+ircd::setmode($ssnick, main_conf_diag, '+o', $ssnick);
+
+add_timer('', 5, __PACKAGE__, 'spamserv::ss_newclient');
+
+sub ss_newclient {
+ unless (!module::is_loaded('services')) {
+ open ((my $SSNICKFILE), main::PREFIX()."/config/spamserv/nicklist.txt");
+ my ($nick, $ident, $hostmask) = ('','','');
+ my @hexset = ('A'..'F','0'..'9');
+ srand;
+ rand($.) < 1 and ($nick=$_) while <$SSNICKFILE>;
+ chomp $nick;
+ close $SSNICKFILE;
+ if (!nickserv::is_registered($nick) && !nickserv::is_online($nick)) {
+ $ident = "htIRC-".lc(misc::gen_uuid(1,4));
+ for (my $i = 1;$i <= 3;$i++) {
+ for (my $x = 1;$x <= 8;$x++) {
+ $hostmask .= $hexset[rand @hexset];
+ }
+ $hostmask .= ".";
+ }
+ $hostmask .= "IP";
+ $fakehost = $nick."!".$ident."@".$hostmask;
+
+ agent_connect($nick, $ident, $hostmask,'+pqH', 'WWW user');
+ agent_join($nick, main_conf_diag);
+ ircd::setmode($ssnick, main_conf_diag, '+h', $nick);
+
+ $idlelength = int(rand($conf{'idlemax'} - $conf{'idlemin'})) + $conf{'idlemin'};
+
+ add_timer($fakehost, $idlelength, __PACKAGE__, 'spamserv::ss_respawn');
+
+ join_chans();
+ }
+ else {
+ add_timer('', 30, __PACKAGE__, 'spamserv::ss_newclient');
+ }
+ }
+}
+
+sub ss_privmsg {
+ my ($src, $dst, $msg) = @_;
+ if (lc $dst eq lc((split /!/,$fakehost)[0])) {
+ ircd::privmsg("SpamServ", main_conf_diag, "Received PRIVMSG: <$src> $msg");
+ }
+ elsif (lc $dst eq "spamserv") {
+ my $user = { NICK => $src, AGENT => $dst };
+ unless(adminserv::is_ircop($user)) {
+ notice($user, "Permission denied");
+ return;
+ }
+ my @args = split(/\s+/, $msg);
+ my $cmd = shift @args;
+
+ if ($cmd =~ /^help$/i) {
+ sendhelp($user, 'spamserv', @args);
+ }
+
+ elsif ($cmd =~ /^rehash/i) {
+ notice($user, "Loading configuration");
+ loadconf();
+ }
+
+ if ($cmd =~ /^listconf$/i) {
+ notice($user, "Configuration:", list_conf);
+ }
+
+ elsif ($cmd =~ /^save/i) {
+ notice($user, "Saving configuration");
+ saveconf();
+ }
+
+ elsif ($msg =~ /^set (\S+) (.*)/i) {
+ if (!adminserv::is_svsop($user, adminserv::S_ROOT())) {
+ notice($user, 'You do not have sufficient rank for this command');
+ return;
+ }
+ if (update_conf($1, $2)) {
+ notice($user, "Configuration: $1 = $2");
+ } else {
+ notice($user, "This appears to be an invalid option");
+ }
+ }
+ elsif ($cmd =~ /^watch$/i) {
+ ss_watch($user, shift @args, @args);
+ }
+ }
+}
+
+sub ss_notice {
+ my ($src, $dst, $msg) = @_;
+ if (lc $dst eq lc((split /!/,$fakehost)[0])) {
+ ircd::privmsg("SpamServ", main_conf_diag, "Received NOTICE: -$src- $msg");
+ }
+ elsif ($dst =~ /^(?:\+|%|@|&|~)?(#.*)/ and exists($chanlist{lc $1})) {
+ ircd::privmsg("SpamServ", main_conf_diag, "Received NOTICE: -$src:$dst- $msg");
+ }
+
+}
+
+sub ss_chnotice {
+ my ($nick, $cn, $msgs) = @_;
+ $cn =~ s/^[+%@&~]+//;
+ return unless exists($chanlist{lc $cn});
+ foreach my $message (@$msgs) {
+ my $message = "-$nick:$cn- $message";
+ }
+ ircd::privmsg("SpamServ", main_conf_diag, @$msgs);
+}
+
+sub ss_respawn($) {
+ my ($fakehost) = @_;
+ if (defined($fakehost)) {
+ foreach my $cn (keys(%chanlist)) {
+ agent_part((split /!/, $fakehost)[0], $cn, '');
+ }
+ agent_quit((split /!/, $fakehost)[0], '');
+ add_timer('', 120, __PACKAGE__, 'spamserv::ss_newclient');
+ undef $fakehost;
+ }
+}
+
+sub ss_watch($$@) {
+ my ($user, $cmd, @args) = @_;
+ if ($cmd =~ /^add$/i) {
+ if (@args == 1) {
+ add_channel($user,$args[0]);
+ } else {
+ notice($user, 'Syntax: WATCH ADD <#chan>');
+ }
+ }
+ if ($cmd =~ /^del(ete)?$/i) {
+ if (@args == 1) {
+ del_channel($user,$args[0]);
+ } else {
+ notice($user, 'Syntax: WATCH DEL <#chan>');
+ }
+ }
+ elsif ($cmd =~ /^list$/i) {
+ ss_list($user);
+ }
+}
+
+sub ss_list($) {
+ my ($user) = @_;
+ notice($user, 'Channels currently being watched');
+ foreach my $cn (keys(%chanlist)) {
+ notice($user, ' '.$cn);
+ }
+}
+
+sub add_channel($$) {
+ my ($user, $cn) = @_;
+ if (!exists($chanlist{lc $cn})) {
+ $chanlist{lc $cn} = 1;
+ agent_join((split /!/, $fakehost)[0], $cn) if defined $fakehost;
+ notice($user, "Channel \002$cn\002 will now be watched");
+ savechans();
+ return 1;
+ } else {
+ notice($user, "Channel \002$cn\002 is already being watched");
+ return 0;
+ }
+}
+
+sub del_channel($$) {
+ my ($user, $cn) = @_;
+ if (exists($chanlist{lc $cn})) {
+ delete($chanlist{lc $cn});
+ agent_part((split /!/, $fakehost)[0], $cn, '') if defined $fakehost;
+ notice($user, "Channel \002$cn\002 will not be watched");
+ savechans();
+ return 1;
+ } else {
+ notice($user, "Channel \002$cn\002 is not being watched");
+ return 0;
+ }
+}
+
+sub savechans() {
+ my @channels = keys(%chanlist);
+ Storable::nstore(\@channels, "config/spamserv/chans.conf");
+}
+
+sub saveconf() {
+ writeHash(\%conf, "config/spamserv/spamserv.conf");
+}
+
+sub list_conf() {
+ my @k = keys(%conf);
+ my @v = values(%conf);
+ my @reply;
+
+ for(my $i=0; $i<@k; $i++) {
+ push @reply, $k[$i]." = ".$v[$i];
+ }
+ return @reply;
+}
+
+sub loadconf() {
+ # doesn't seem to pick up any of the values
+ %conf = readHash("config/spamserv/spamserv.conf");
+}
+
+sub loadchans() {
+ return unless(-f "config/spamserv/chans.conf");
+ my @channels = @{Storable::retrieve("config/spamserv/chans.conf")};
+ foreach my $cn (@channels) {
+ $chanlist{lc $cn} = 1;
+ }
+}
+
+sub update_conf($$) {
+ my ($k,$v) = @_;
+ if (exists($conf{$k})) {
+ $conf{$k} = $v;
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub join_chans() {
+ foreach my $cn (keys(%chanlist)) {
+ agent_join((split /!/, $fakehost)[0], $cn);
+ }
+}
+
+sub init { }
+sub begin { }
+sub end { }
+sub unload { savechans(); saveconf(); }
+
+1;
--- /dev/null
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+package sql;
+use strict;
+
+use Time::HiRes qw( time );
+
+use SrSv::MySQL qw( $dbh );
+use SrSv::Text::Format qw( columnar );
+use SrSv::IRCd::Event qw( addhandler );
+use SrSv::Agent;
+use SrSv::Conf2Consts qw( main );
+use SrSv::User qw( get_user_nick );
+use SrSv::User::Notice;
+
+# these are really a layer violation
+# but there's not much else way to requeue our events
+use SrSv::Process::Worker qw( multi );
+use SrSv::IRCd::Event qw( callfuncs );
+
+use SrSv::Process::InParent qw( ev_privmsg );
+
+our %users;
+
+our $sqlnick = 'SQLServ';
+
+agent_connect($sqlnick, 'services', undef, '+pqzBGHS', 'Database Query Agent');
+agent_join($sqlnick, main_conf_diag);
+ircd::setmode($sqlnick, main_conf_diag, '+o', $sqlnick);
+
+addhandler('PRIVMSG', undef, lc $sqlnick, 'sql::ev_privmsg');
+sub ev_privmsg {
+ my ($src, $dst, $payload) = @_;
+ my $user = { NICK => $src, AGENT => $sqlnick };
+ #FIXME: More fine grained permissions needed.
+ # SELECT is relatively safe. EXPLAIN is too.
+ unless(adminserv::is_svsop($user, adminserv::S_ROOT())) {
+ notice($user, "Permission denied"); #FIXME: need $err_deny
+ return;
+ }
+ #irssi's splitlong uses ... for beginning and end of a split payload
+ $payload =~ s/(^\.\.\.|\.\.\.$)//g;
+ if($payload =~ /^help/) {
+ notice($user, "Sorry, no documentation yet.");
+ }
+ elsif($payload =~ /^(SELECT|SHOW CREATE|SHOW TABLES|UPDATE|INSERT|ALTER|EXPLAIN) ?(.*)$/i) {
+ my $cmd = $1;
+ my $statement = $2;
+ $users{$src}{STMT} = $statement;
+ $users{$src}{CMD} = uc $cmd;
+ } else {
+ $users{$src}{STMT} .= ' '.$payload;
+ }
+ if ($payload =~ /(\\G|;)$/) {
+ if(!multi) {
+ ev_loopback($src, $dst, "$users{$src}{CMD} $users{$src}{STMT}");
+ } else {
+ callfuncs('LOOPBACK', 0, 1, 0,
+ [$src, $sqlnick, "$users{$src}{CMD} $users{$src}{STMT}"]);
+ }
+ delete($users{$src});
+ }
+}
+
+addhandler('LOOPBACK', undef, lc $sqlnick, 'sql::ev_loopback');
+sub ev_loopback {
+ my ($src, $dst, $payload) = @_;
+ my $user = { NICK => $src, AGENT => $sqlnick };
+ if($payload =~ /^SELECT (.*)$/i) {
+ my $statement = $1;
+ if ($statement =~ /(\\G|;)$/) {
+ my $mode = ($1 eq ';' ? 1 : 2);
+ SELECT($user, $statement, $mode);
+ }
+ } elsif($payload =~ /^SHOW (CREATE|TABLES) ?(.*)$/i) {
+ my $cmd = $1;
+ my $statement = $2;
+ if ($statement =~ /(\\G|;)$/) {
+ my $mode = ($1 eq ';' ? 1 : 2);
+ if(uc($cmd) eq 'CREATE') {
+ SHOW_CREATE($user, $statement, $mode);
+ }
+ elsif(uc($cmd) eq 'TABLES') {
+ SHOW_TABLES($user, $statement, $mode);
+ }
+ }
+ } elsif($payload =~ /^UPDATE (.*)$/i) {
+ my $statement = $1;
+ if ($statement =~ /(\\G|;)$/) {
+ UPDATE($user, $statement);
+ }
+ } elsif($payload =~ /^INSERT (.*)$/i) {
+ my $statement = $1;
+ if ($statement =~ /(\\G|;)$/) {
+ INSERT($user, $statement);
+ }
+ } elsif($payload =~ /^ALTER (.*)$/i) {
+ my $statement = $1;
+ if ($statement =~ /(\\G|;)$/) {
+ ALTER($user, $statement);
+ }
+ } elsif($payload =~ /^EXPLAIN (.*)$/i) {
+ my $statement = $1;
+ if ($statement =~ /(\\G|;)$/) {
+ my $mode = ($1 eq ';' ? 1 : 2);
+ EXPLAIN($user, $statement, $mode);
+ }
+ }
+}
+
+sub queryMode2($$) {
+ my ($inRef, $namesRef) = @_;
+ my @out;
+ for(my $i = 1; $i <= scalar(@$inRef); $i++) {
+ my @rowIn = @{$inRef->[$i-1]};
+ my @rowTmp;
+ push @out, "*************************** $i. row ***************************";
+ for(my $j = 0; $j < scalar(@rowIn); $j++) {
+ push @rowTmp, [$namesRef->[$j].':', $rowIn[$j]];
+ }
+ push @out, columnar( { JUSTIFIED => 1, NOHIGHLIGHT => 1 }, @rowTmp );
+ }
+ return @out;
+}
+
+sub UPDATE {
+ my ($user, $statement) = @_;
+ notice($user, "Unsupported command");
+}
+sub ALTER {
+ my ($user, $statement) = @_;
+ notice($user, "Unsupported command");
+}
+sub EXPLAIN {
+ my ($user, $statement, $mode) = @_;
+ readonlyQuery($user, 'EXPLAIN', $statement, $mode);
+}
+sub INSERT {
+ my ($user, $statement) = @_;
+ notice($user, "Unsupported command");
+}
+
+sub SELECT {
+ my ($user, $statement, $mode) = @_;
+ readonlyQuery($user, 'SELECT', $statement, $mode);
+}
+
+sub readonlyQuery {
+ my ($user, $cmd, $statement, $mode) = @_;
+ my ($arrayRef, $namesRef);
+ $statement =~ s/(;|\\G)$//;
+ my ($startTime, $endTime, $error);
+ eval {
+ local $SIG{__WARN__} = sub { $error = \@_ };
+ my $sth = $dbh->prepare("$cmd $statement");
+ $startTime = time();
+ my $ret = $sth->execute();
+ if(defined($ret)) {
+ $namesRef = $sth->FETCH('NAME');
+ $arrayRef = $sth->fetchall_arrayref();
+ $endTime = time();
+ }
+ };
+ if($@) {
+ #ircd::debug("AIEEEEE! $@");
+ notice($user, "AIEEEEE!", "$cmd $statement", $@, '--');
+ } elsif(!defined($arrayRef)) {
+ notice($user, 'Error:', @$error, '--');
+ } elsif(scalar(@$arrayRef)) {
+ my @out;
+ if($mode == 2) {
+ @out = queryMode2($arrayRef, $namesRef);
+ } else {
+ @out = columnar( { BORDER => 1, NOHIGHLIGHT => 1 }, $namesRef, @$arrayRef );
+ }
+ my $elapsed = $endTime-$startTime;
+ $elapsed = sprintf('%.2f sec%s', $elapsed, $elapsed == 1 ? '' : 's');
+ notice($user, @out, scalar(@$arrayRef).' rows in set ('.$elapsed.')');
+ } else {
+ my $elapsed = $endTime-$startTime;
+ $elapsed = sprintf('%.2f sec%s', $elapsed, $elapsed == 1 ? '' : 's');
+ notice($user, "Empty result. ($elapsed)");
+ }
+}
+
+sub SHOW_CREATE {
+ my ($user, $statement, $mode) = @_;
+ readonlyQuery($user, 'SHOW CREATE', $statement, $mode);
+}
+
+sub SHOW_TABLES {
+ my ($user, $statement, $mode) = @_;
+ readonlyQuery($user, 'SHOW TABLES', $statement, $mode);
+}
+
+
+sub init { }
+sub begin { }
+sub end { }
+sub unload { }
+
+1;
--- /dev/null
+Index: modules/country.pm
+===================================================================
+--- modules/country.pm (revision 2760)
++++ modules/country.pm (working copy)
+@@ -37,11 +37,11 @@ our ($get_ip_country, $get_ip_country_at
+
+ proc_init {
+ $get_ip_country = $dbh->prepare_cached("SELECT country FROM country WHERE
+- ? BETWEEN low AND high");
++ MBRCONTAINS(ip_poly, POINTFROMWKB(POINT(?, 0)))");
+ $get_ip_country_aton = $dbh->prepare_cached("SELECT country FROM country WHERE
+- INET_ATON(?) BETWEEN low AND high");
++ MBRCONTAINS(ip_poly, POINTFROMWKB(POINT(INET_ATON(?), 0)))");
+ $get_user_country = $dbh->prepare_cached("SELECT country FROM country, user WHERE
+- user.ip BETWEEN low AND high and user.id=?");
++ MBRCONTAINS(ip_poly, POINTFROMWKB(POINT(user.ip, 0))) and user.id=?");
+ };
+
+ sub get_ip_country($) {
+Index: utils/country-table.pl
+===================================================================
+--- utils/country-table.pl (revision 2785)
++++ utils/country-table.pl (working copy)
+@@ -52,6 +52,8 @@ sub main() {
+ newTable($dbh);
+ print "Inserting data... ";
+ loadData($dbh);
++ print "Converting data...\n";
++ convert($dbh);
+ print "Removing old table...\n";
+ cleanup($dbh);
+ $dbh->disconnect();
+@@ -124,7 +126,7 @@ sub newTable($) {
+
+ $dbh->do("DROP TABLE IF EXISTS newcountry");
+ $dbh->do(
+- "CREATE TABLE `newcountry` (
++ "CREATE TABLE `tmpcountry` (
+ `low` int unsigned NOT NULL default 0,
+ `high` int unsigned NOT NULL default 0,
+ `country` char(2) NOT NULL default '-',
+@@ -136,7 +138,7 @@ sub newTable($) {
+ sub loadData($) {
+ my ($dbh) = @_;
+
+- my $add_entry = $dbh->prepare("INSERT INTO newcountry SET low=INET_ATON(?), high=INET_ATON(?), country=?");
++ my $add_entry = $dbh->prepare("INSERT INTO tmpcountry SET low=INET_ATON(?), high=INET_ATON(?), country=?");
+
+ $| = 1;
+ my $unpackFile = PREFIX."/data/$unpackname";
+@@ -145,8 +147,8 @@ sub loadData($) {
+ my ($i, @entries);
+
+ open ((my $COUNTRYTABLE), '<', $unpackFile);
+- $dbh->do("ALTER TABLE `newcountry` DISABLE KEYS");
+- $dbh->do("LOCK TABLES newcountry WRITE");
++ $dbh->do("ALTER TABLE `tmpcountry` DISABLE KEYS");
++ $dbh->do("LOCK TABLES tmpcountry WRITE");
+ while(my $x = <$COUNTRYTABLE>) {
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+@@ -158,19 +160,40 @@ sub loadData($) {
+ push @entries,
+ '(INET_ATON('.$dbh->quote($low).'),'.'INET_ATON('.$dbh->quote($high).'),'.$dbh->quote($country).')';
+ if (scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+- $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries));
++ $dbh->do("INSERT IGNORE INTO tmpcountry (low, high, country) VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+- $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
++ $dbh->do("INSERT IGNORE INTO tmpcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
+ $dbh->do("UNLOCK TABLES");
+- $dbh->do("ALTER TABLE `newcountry` ENABLE KEYS");
++ $dbh->do("ALTER TABLE `tmpcountry` ENABLE KEYS");
+ close $COUNTRYTABLE;
+ print "\b\b\b\bdone.\n";
+ }
+
++sub convert($) {
++ my ($dbh) = @_;
++ $dbh->do(
++ "CREATE TABLE newcountry (
++ id int unsigned not null AUTO_INCREMENT,
++ ip_poly polygon not null,
++ low int unsigned not null,
++ high int unsigned not null,
++ country char(2) not null default '-',
++ PRIMARY KEY (id),
++ SPATIAL INDEX (ip_poly)
++ );"
++ );
++ $dbh->do(
++ "INSERT INTO newcountry (low,high,country,ip_poly)
++ SELECT low, high, country,
++ GEOMFROMWKB(POLYGON(LINESTRING( POINT(low, -1), POINT(high, -1),
++ POINT(high, 1), POINT(low, 1), POINT(low, -1)))) FROM tmpcountry;"
++ );
++}
++
+ sub cleanup() {
+ my ($dbh) = @_;
+
+Index: utils/country-table2.pl
+===================================================================
+--- utils/country-table2.pl (revision 2785)
++++ utils/country-table2.pl (working copy)
+@@ -58,6 +58,9 @@ sub main() {
+ newTable($dbh);
+ print "Inserting data... ";
+ loadData($dbh);
++ print "Converting data...\n";
++ convert($dbh);
++ print "Performing cleanup...\n";
+ cleanup($dbh);
+ $dbh->disconnect();
+ print "Country table update complete.\n";
+@@ -124,7 +127,7 @@ sub newTable($) {
+
+ $dbh->do("DROP TABLE IF EXISTS newcountry");
+ $dbh->do(
+- "CREATE TABLE `newcountry` (
++ "CREATE TEMPORARY TABLE `tmpcountry` (
+ `low` int unsigned NOT NULL default 0,
+ `high` int unsigned NOT NULL default 0,
+ `country` char(2) NOT NULL default '-',
+@@ -142,9 +145,9 @@ sub loadData($) {
+ my ($i, @entries);
+
+ open ((my $COUNTRYTABLE), '<', $unpackPath);
+- my $add_entry = $dbh->prepare("INSERT INTO newcountry SET low=INET_ATON(?), high=INET_ATON(?), country=?");
+- $dbh->do("ALTER TABLE `newcountry` DISABLE KEYS");
+- $dbh->do("LOCK TABLES newcountry WRITE");
++ my $add_entry = $dbh->prepare("INSERT INTO tmpcountry SET low=INET_ATON(?), high=INET_ATON(?), country=?");
++ $dbh->do("ALTER TABLE `tmpcountry` DISABLE KEYS");
++ $dbh->do("LOCK TABLES tmpcountry WRITE");
+ while(my $x = <$COUNTRYTABLE>) {
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+@@ -159,18 +162,40 @@ sub loadData($) {
+ push @entries,
+ '(INET_ATON('.$dbh->quote($low).'),'.'INET_ATON('.$dbh->quote($high).'),'.$dbh->quote($country).')';
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+- $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries));
++ $dbh->do("INSERT IGNORE INTO tmpcountry (low, high, country) VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+- $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
++ $dbh->do("INSERT IGNORE INTO tmpcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
+ $dbh->do("UNLOCK TABLES");
+- $dbh->do("ALTER TABLE `newcountry` ENABLE KEYS");
++ $dbh->do("ALTER TABLE `tmpcountry` ENABLE KEYS");
+ close $COUNTRYTABLE;
+ }
+
++sub convert($) {
++ my ($dbh) = @_;
++ $dbh->do(
++ "CREATE TABLE newcountry (
++ id int unsigned not null AUTO_INCREMENT,
++ ip_poly polygon not null,
++ low int unsigned not null,
++ high int unsigned not null,
++ country char(2) not null default '-',
++ PRIMARY KEY (`id`),
++ UNIQUE KEY (`low`, `high`),
++ SPATIAL INDEX (`ip_poly`)
++ );"
++ );
++ $dbh->do(
++ "INSERT INTO newcountry (low,high,country,ip_poly)
++ SELECT low, high, country,
++ GEOMFROMWKB(POLYGON(LINESTRING( POINT(low, -1), POINT(high, -1),
++ POINT(high, 1), POINT(low, 1), POINT(low, -1)))) FROM tmpcountry;"
++ );
++}
++
+ sub cleanup($) {
+ my ($dbh) = @_;
+
+Index: utils/country-table3.pl
+===================================================================
+--- utils/country-table3.pl (revision 2785)
++++ utils/country-table3.pl (working copy)
+@@ -58,6 +58,8 @@ sub main() {
+ newTable($dbh);
+ print "Inserting data... ";
+ loadData($dbh);
++ print "Converting data...\n";
++ convert($dbh);
+ print "Removing old table...\n";
+ cleanup($dbh);
+ $dbh->disconnect();
+@@ -95,7 +97,7 @@ sub newTable($) {
+
+ $dbh->do("DROP TABLE IF EXISTS newcountry");
+ $dbh->do(
+- "CREATE TABLE `newcountry` (
++ "CREATE TEMPORARY TABLE `tmpcountry` (
+ `low` int unsigned NOT NULL default 0,
+ `high` int unsigned NOT NULL default 0,
+ `country` char(2) NOT NULL default '-',
+@@ -106,7 +108,7 @@ sub newTable($) {
+
+ sub loadData($) {
+ my ($dbh) = @_;
+- my $add_entry = $dbh->prepare("INSERT IGNORE INTO newcountry SET low=?, high=?, country=?");
++ my $add_entry = $dbh->prepare("INSERT IGNORE INTO tmpcountry SET low=?, high=?, country=?");
+
+ $| = 1;
+ my $unpackPath = PREFIX.'/data/'.srcname;
+@@ -115,8 +117,8 @@ sub loadData($) {
+ my ($i, @entries);
+
+ open ((my $COUNTRYTABLE), '<', $unpackPath);
+- $dbh->do("ALTER TABLE `newcountry` DISABLE KEYS");
+- $dbh->do("LOCK TABLES newcountry WRITE");
++ $dbh->do("ALTER TABLE `tmpcountry` DISABLE KEYS");
++ $dbh->do("LOCK TABLES tmpcountry WRITE");
+ while(my $x = <$COUNTRYTABLE>) {
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+@@ -131,21 +133,43 @@ sub loadData($) {
+ next if lc $country eq 'eu';
+ push @entries, '('.$dbh->quote($low).','.$dbh->quote($high).','.$dbh->quote($country).')';
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+- $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries));
++ $dbh->do("INSERT IGNORE INTO tmpcountry (low, high, country) VALUES ".join(',', @entries));
+ @entries = ();
+ }
+ }
+
+ $i++;
+ }
+- $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
++ $dbh->do("INSERT IGNORE INTO tmpcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
+
+ $dbh->do("UNLOCK TABLES");
+- $dbh->do("ALTER TABLE `newcountry` ENABLE KEYS");
++ $dbh->do("ALTER TABLE `tmpcountry` ENABLE KEYS");
+ close $COUNTRYTABLE;
+ print "\b\b\b\bdone.\n";
+ }
+
++sub convert($) {
++ my ($dbh) = @_;
++ $dbh->do(
++ "CREATE TABLE newcountry (
++ id int unsigned not null AUTO_INCREMENT,
++ ip_poly polygon not null,
++ low int unsigned not null,
++ high int unsigned not null,
++ country char(2) not null default '-',
++ PRIMARY KEY (id),
++ UNIQUE KEY (`low`, `high`),
++ SPATIAL INDEX (ip_poly)
++ );"
++ );
++ $dbh->do(
++ "INSERT INTO newcountry (low,high,country,ip_poly)
++ SELECT low, high, country,
++ GEOMFROMWKB(POLYGON(LINESTRING( POINT(low, -1), POINT(high, -1),
++ POINT(high, 1), POINT(low, 1), POINT(low, -1)))) FROM tmpcountry;"
++ );
++}
++
+ sub cleanup($) {
+ my ($dbh) = @_;
+
--- /dev/null
+Index: SrSv/Process/Worker.pm
+===================================================================
+--- SrSv/Process/Worker.pm (revision 3510)
++++ SrSv/Process/Worker.pm (working copy)
+@@ -33,7 +33,7 @@ use Event;
+ use English qw( -no_match_vars );
+ use IO::Socket;
+ use IO::File;
+-use Storable qw(fd_retrieve store_fd);
++use Storable qw(fd_retrieve store_fd dclone);
+
+ use SrSv::Debug;
+
+@@ -181,6 +181,14 @@ sub kill_all_workers() {
+ sub do_callback_in_child {
+ my ($callback, $message) = @_;
+
++ # this whole thing is a workaround for perl 5.12's Storable.
++ # Can't pass a regexp through Storable.
++ if(ref($callback->{TRIGGER_COND}->{DST}) || ref($callback->{TRIGGER_COND}->{SRC})) {
++ $callback->{TRIGGER_COND} = dclone($callback->{TRIGGER_COND});
++ delete $callback->{TRIGGER_COND}->{DST};
++ #use Data::Dumper;
++ #ircd::debug( split($/, Data::Dumper::Dumper($worker->{UNIT})) );
++ }
+ if(my $worker = pop @free_workers) {
+ print "Asking worker ".$worker->{NUMBER}." to call ".$callback->{CALL}."\n" if DEBUG;
+ #store_fd([$unit], $worker->{SOCKET});
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+no strict 'refs';
+
+use constant { # Need them up here, before anybody derefs them.
+ ST_PRECONNECT => 0,
+ ST_LOADMOD => 1,
+ ST_NORMAL => 2,
+ ST_SHUTDOWN => 3,
+ ST_CLOSED => 4,
+ NETDUMP => 0,
+};
+
+use Cwd qw( abs_path getcwd );
+use File::Basename;
+
+BEGIN {
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => dirname(abs_path($0)),
+ );
+ require constant; import constant(\%constants);
+}
+# FIXME: remove the chdir call!
+chdir PREFIX;
+use lib PREFIX, "@{[PREFIX]}/CPAN";
+
+die("Please don't run services as root!\n") if $< eq 0;
+
+use Getopt::Long;
+BEGIN {
+ my @debug_pkgs;
+ my $compile_only = 0;
+
+ GetOptions(
+ "debug:s" => \@debug_pkgs,
+ "compile" => \$compile_only,
+ );
+
+ if(@debug_pkgs) {
+ require SrSv::Debug;
+
+ SrSv::Debug::enable();
+ push @debug_pkgs, 'main';
+ foreach my $pkg (@debug_pkgs) {
+ $SrSv::Debug::debug_pkgs{$pkg} = 1;
+ }
+ }
+ import constant { COMPILE_ONLY => $compile_only };
+}
+
+use SrSv::Conf::main;
+
+use SrSv::OnIRC (1);
+
+use SrSv::Debug;
+use SrSv::Log;
+use SrSv::Conf2Consts qw(main);
+
+use IO::Socket;
+use Carp;
+
+use SrSv::IRCd::Send; # <-- is package ircd
+use libs::misc;
+use libs::event;
+use libs::modes;
+use libs::module;
+
+use SrSv::Process::Init ();
+use SrSv::Process::Worker qw(spawn write_pidfiles);
+use SrSv::Message qw(add_callback);
+use SrSv::Timer qw(begin_timer);
+
+#*conf = \%main_conf; #FIXME
+
+STDOUT->autoflush(1);
+STDERR->autoflush(1);
+
+our $progname = 'SurrealServices';
+our $version = '0.4.3-pre';
+our $extraversion = 'configured for UnrealIRCd 3.2.8.1';
+
+#FIXME: Figure out where $rsnick belongs and update all references
+our $rsnick; *rsnick = \$core::rsnick;
+
+print "Starting $progname $version.\n";
+
+#config::loadconfig();
+
+{
+ use SrSv::DB::Schema;
+ my $schemaVer = check_schema();
+ my $newestSchema = find_newest_schema();
+ if($schemaVer != $newestSchema) {
+ print "Found schema version ($schemaVer). Expected ($newestSchema). Did you run db-setup.pl ?\n";
+ die unless COMPILE_ONLY;
+ }
+}
+
+module::load();
+exit() if COMPILE_ONLY;
+print "Connecting...";
+ircd::serv_connect();
+print " Connected.\n";
+
+unless(DEBUG) {
+ exit if fork;
+ close STDIN;
+ close STDOUT;
+ close STDERR;
+ open STDIN, '<', '/dev/null';
+ open STDOUT, '>', '/dev/null';
+ open STDERR, '>', '/dev/null';
+ setpgrp();
+}
+
+if(main_conf_procs) {
+ for(1..main_conf_procs) { spawn(); }
+}
+write_pidfiles();
+
+SrSv::Process::Init::do_init();
+
+module::begin();
+
+begin_timer();
+
+event::loop();
--- /dev/null
+#0.4.3
+alter table user
+ modify column id bigint unsigned not null auto_increment,
+ drop primary key,
+ add primary key using btree (id),
+ drop key nick,
+ add key nick using hash (nick),
+ drop key ip,
+ add key using btree (ip);
+
+# Duplicate key given PRIMARY already indexes this column first.
+ALTER TABLE `nickalias` DROP KEY `root`;
+
+# Duplicate keys given PRIMARY already indexes this column first.
+ALTER TABLE `akick` DROP INDEX `chan`;
+ALTER TABLE `silence` DROP KEY `nick`;
+ALTER TABLE `nickid` DROP INDEX `id`, ADD KEY `nrid` (`nrid`);
+ALTER TABLE `watch` DROP KEY `nick`;
+
+# merged into above 'alter table user'
+#ALTER TABLE `user` MODIFY `id` bigint unsigned NOT NULL auto_increment;
+DROP TABLE `srsv_schema`;
+CREATE table `srsv_schema` (
+ `ver` int unsigned NOT NULL,
+ `singleton` int unsigned default 0,
+ PRIMARY KEY (`singleton`)
+) ENGINE=MyISAM;
+REPLACE INTO `srsv_schema` (`ver`) VALUES (4003000);
--- /dev/null
+CREATE TABLE usertags (
+ `userid` bigint NOT NULL,
+ `tag` char(30) NOT NULL,
+ PRIMARY KEY USING HASH (`userid`, `tag`)
+) ENGINE=HEAP;
+
+REPLACE INTO `srsv_schema` (`ver`) VALUES (4003001);
--- /dev/null
+ALTER TABLE `user` MODIFY `ip` bigint unsigned,
+ ADD COLUMN `ipv6` char(39) default NULL;
+
+REPLACE INTO `srsv_schema` (`ver`) VALUES (4003002);
--- /dev/null
+ALTER TABLE `user` DROP COLUMN guest;
+
+REPLACE INTO `srsv_schema` (`ver`) VALUES (4003003);
--- /dev/null
+ALTER TABLE `chanreg` ADD `bantime` BIGINT( 20 ) UNSIGNED NOT NULL;
+
+CREATE TABLE IF NOT EXISTS `tmpban` (
+ `channel` varchar(20) NOT NULL,
+ `banmask` varchar(20) NOT NULL,
+ `expiry` bigint(20) unsigned NOT NULL,
+ `timeset` bigint(20) unsigned NOT NULL,
+ KEY `banmask` (`banmask`),
+ KEY `timeset` (`timeset`)
+) ENGINE=MyISAM DEFAULT CHARSET=latin1;
+
+REPLACE INTO `srsv_schema` (`ver`) VALUES (4003004);
--- /dev/null
+ALTER TABLE `chanreg` DROP `bantime`;
+ALTER TABLE `chanreg` ADD `bantime` int(11) UNSIGNED default 0;
+
+DROP TABLE IF EXISTS `tmpban`;
+CREATE TABLE IF NOT EXISTS `tmpban` (
+ `channel` varchar(32) NOT NULL,
+ `banmask` varchar(110) NOT NULL,
+ `expiry` bigint(20) unsigned NOT NULL,
+ `timeset` bigint(20) unsigned NOT NULL,
+ UNIQUE KEY `banmask` (`channel`, `banmask`),
+ KEY `expiry` (`expiry`)
+) ENGINE=MyISAM DEFAULT CHARSET=latin1;
+
+REPLACE INTO `srsv_schema` (`ver`) VALUES (4003005);
--- /dev/null
+0.4.2 is the first time in a long time that we are changing the database
+format that requires a script to run.
+
+This version has both an updatedb-0.4.2.sql file, and an
+upgrade-0.4.2.pl script. The order you run this in does not matter.
+
+fwiw, for now, the upgrade script is optional, but recommended for
+security reasons. For now, 0.4.2 will remain compatible with the
+non-hashed passwords, but this may be removed at a later date.
+
+This is a major change in how passwords will work. SENDPASS is being
+changed. If the password is hashed, it will not send the actual password
+but an authentication code that will allow the user to identify and
+change their password. Additionally, GETPASS has been removed, as it
+will no longer work.
+
+Please notify your staff. Notify your users too.
--- /dev/null
+CREATE TABLE `akick` (
+ `chan` varchar(32) NOT NULL default '',
+ `nick` varchar(30) NOT NULL default '',
+ `ident` varchar(10) NOT NULL default '',
+ `host` varchar(64) NOT NULL default '',
+ `adder` varchar(30) NOT NULL default '',
+ `reason` text,
+ `time` int(10) unsigned NOT NULL default '0',
+ PRIMARY KEY (`chan`,`nick`,`ident`,`host`)
+) ENGINE=MyISAM;
+
+
+CREATE TABLE `bot` (
+ `nick` char(30) NOT NULL default '',
+ `ident` char(10) NOT NULL default '',
+ `vhost` char(64) NOT NULL default '',
+ `gecos` char(50) NOT NULL default '',
+ `flags` mediumint NOT NULL default '1',
+ PRIMARY KEY (`nick`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `chanacc` (
+ `chan` char(32) NOT NULL default '',
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `level` tinyint(3) NOT NULL default '0',
+ `adder` char(30) NOT NULL default '',
+ `time` int(10) unsigned NOT NULL default '0',
+ `last` int(10) unsigned NOT NULL default '0',
+ PRIMARY KEY (`chan`,`nrid`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `chanclose` (
+ `chan` char(30) NOT NULL default '',
+ `nick` char(30) NOT NULL default '',
+ `reason` text NOT NULL default '',
+ `time` int(11) unsigned NOT NULL default '0',
+ `type` tinyint(3) unsigned NOT NULL default '0',
+ PRIMARY KEY (`chan`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `chanlvl` (
+ `chan` char(32) NOT NULL default '',
+ `perm` smallint(5) unsigned NOT NULL default '0',
+ `level` tinyint(4) NOT NULL default '0',
+ PRIMARY KEY (`chan`,`perm`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `chanperm` (
+ `name` char(10) NOT NULL default '',
+ `id` smallint(5) unsigned NOT NULL auto_increment,
+ `level` tinyint(4) NOT NULL default '0',
+ `max` tinyint(3) unsigned NOT NULL default 0,
+ PRIMARY KEY (`name`),
+ UNIQUE KEY `id` (`id`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `chanreg` (
+ `chan` varchar(32) NOT NULL default '',
+ `descrip` varchar(255) default NULL,
+ `regd` int(11) unsigned NOT NULL default '0',
+ `last` int(11) unsigned NOT NULL default '0',
+ `topicer` varchar(30) NOT NULL default '',
+ `topicd` int(11) unsigned NOT NULL default '0',
+ `modelock` varchar(63) binary NOT NULL default '+ntr',
+ `founderid` int(11) unsigned NOT NULL default '0',
+ `successorid` int(11) unsigned NOT NULL default '0',
+ `bot` varchar(30) NOT NULL default '',
+ `flags` mediumint(8) unsigned NOT NULL default '0',
+ `bantype` tinyint(8) unsigned NOT NULL default '0',
+ PRIMARY KEY (`chan`)
+) ENGINE=MyISAM;
+
+
+CREATE TABLE `ircop` (
+ `nick` char(30) NOT NULL default '',
+ `level` tinyint(3) unsigned NOT NULL default '0',
+ `pass` char(127) binary NOT NULL default '',
+ PRIMARY KEY (`nick`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `logonnews` (
+ `setter` char(30) NOT NULL default '',
+ `type` char(1) NOT NULL default 'u',
+ `id` tinyint(3) unsigned NOT NULL default 0,
+ `time` int(11) unsigned NOT NULL default '0',
+ `expire` int(11) unsigned NOT NULL default '0',
+ `msg` text NOT NULL
+) ENGINE=MyISAM;
+
+CREATE TABLE `memo` (
+ `src` varchar(30) NOT NULL default '',
+ `dstid` int(11) unsigned NOT NULL default '0',
+ `chan` varchar(32) NOT NULL default '',
+ `time` int(11) unsigned NOT NULL default '0',
+ `flag` tinyint(3) unsigned NOT NULL default '0',
+ `msg` text NOT NULL,
+ PRIMARY KEY (`src`,`dstid`,`chan`,`time`),
+ KEY `dst` (`dstid`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `ms_ignore` (
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `ignoreid` int(11) unsigned NOT NULL default '0',
+ `time` int(11) unsigned NOT NULL default '0',
+ PRIMARY KEY (`nrid`,`ignoreid`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `nickalias` (
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `alias` char(30) NOT NULL default '',
+ `protect` tinyint(4) NOT NULL default '1',
+ `last` int(11) unsigned NOT NULL default 0,
+ PRIMARY KEY (`nrid`,`alias`),
+ UNIQUE KEY `alias` (`alias`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `nickid` (
+ `id` int(10) unsigned NOT NULL default '0',
+ `nrid` int(11) unsigned NOT NULL default '0',
+ PRIMARY KEY (`id`,`nrid`),
+ KEY `nrid` (`nrid`)
+) ENGINE=HEAP;
+
+CREATE TABLE `nickreg` (
+ `id` int(11) unsigned NOT NULL AUTO_INCREMENT,
+ `nick` char(30) NOT NULL default '',
+ `pass` char(127) binary NOT NULL default '',
+ `email` char(127) NOT NULL default '',
+ `regd` int(11) unsigned NOT NULL default '0',
+ `last` int(11) unsigned NOT NULL default '0',
+ `flags` mediumint(3) unsigned NOT NULL default '1',
+ `ident` char(10) NOT NULL default '',
+ `vhost` char(64) NOT NULL default '',
+ `gecos` char(50) NOT NULL default '',
+ `quit` char(127) NOT NULL default '',
+ `nearexp` tinyint(3) unsigned NOT NULL default '0',
+ PRIMARY KEY (`id`),
+ UNIQUE KEY `nick` (`nick`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `sesexname` (
+ `host` varchar(64) NOT NULL default '',
+ `serv` tinyint(1) NOT NULL default 0,
+ `adder` varchar(3) NOT NULL default '',
+ `lim` mediumint(8) unsigned NOT NULL default 0,
+ `reason` varchar(255) NOT NULL default '',
+ PRIMARY KEY (`host`)
+);
+
+CREATE TABLE `sesexip` (
+ `ip` int(10) unsigned NOT NULL default 0,
+ `mask` tinyint(3) NOT NULL default 0,
+ `adder` varchar(3) NOT NULL default '',
+ `lim` mediumint(8) unsigned NOT NULL default 0,
+ `reason` varchar(255) NOT NULL default '',
+ PRIMARY KEY (`ip`)
+);
+
+CREATE TABLE `qline` (
+ `mask` varchar(30) NOT NULL default '',
+ `setter` varchar(30) NOT NULL default '',
+ `time` int(11) unsigned NOT NULL default '0',
+ `expire` int(11) unsigned NOT NULL default '0',
+ `reason` text NOT NULL,
+ PRIMARY KEY (`mask`),
+ KEY `time` (`time`),
+ KEY `expire` (`expire`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `silence` (
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `mask` char(106) NOT NULL default '',
+ `time` int(10) unsigned NOT NULL default '0',
+ `expiry` int(10) unsigned NOT NULL default '0',
+ `comment` char(100) default NULL,
+ PRIMARY KEY (`nrid`,`mask`)
+) ENGINE=MyISAM;
+
+
+CREATE TABLE `svsop` (
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `level` tinyint(3) unsigned NOT NULL default '0',
+ `adder` char(30) NOT NULL default '',
+ PRIMARY KEY (`nrid`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `vhost` (
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `ident` char(10) NOT NULL default '',
+ `vhost` char(64) NOT NULL default '',
+ `adder` char(30) NOT NULL default '',
+ `time` int(10) unsigned NOT NULL default '0',
+ PRIMARY KEY (`nrid`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `watch` (
+ `nrid` int(11) unsigned NOT NULL default '0',
+ `mask` char(106) NOT NULL default '',
+ `time` int(10) unsigned NOT NULL default '0',
+ PRIMARY KEY (`nrid`,`mask`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `welcome` (
+ `chan` varchar(32) NOT NULL default '',
+ `id` tinyint(3) NOT NULL default '0',
+ `adder` varchar(30) NOT NULL default '',
+ `time` int(10) NOT NULL default '0',
+ `msg` text NOT NULL,
+ PRIMARY KEY (`chan`,`id`)
+) ENGINE=MyISAM;
+
+CREATE TABLE `nicktext` (
+ `nrid` int(11) unsigned NOT NULL default 0,
+ `type` tinyint(3) unsigned NOT NULL default 0,
+ `id` mediumint(8) unsigned NOT NULL default 0,
+ `chan` varchar(32) default NULL,
+ `data` text default NULL,
+ PRIMARY KEY (`nrid`, `type`, `id`, `chan`)
+) ENGINE=MyISAM;
+
+#################################################
+# Volatile tables
+
+DROP TABLE IF EXISTS `chan`;
+CREATE TABLE `chan` (
+ `chan` char(32) NOT NULL default '',
+ `modes` char(63) binary NOT NULL default '',
+ `seq` mediumint(8) unsigned NOT NULL default '0',
+ PRIMARY KEY (`chan`)
+) ENGINE=HEAP;
+
+DROP TABLE IF EXISTS `chanban`;
+CREATE TABLE `chanban` (
+ `chan` varchar(32) NOT NULL default '',
+ `mask` varchar(110) NOT NULL default '',
+ `setter` varchar(30) NOT NULL default '',
+ `time` int(10) unsigned NOT NULL default '0',
+ `type` tinyint(3) unsigned NOT NULL default '0',
+ PRIMARY KEY (`chan`,`mask`,`type`)
+) ENGINE=HEAP;
+
+#DROP TABLE IF EXISTS `chantext`;
+CREATE TABLE `chantext` (
+ `chan` varchar(32) NOT NULL default '',
+ `type` tinyint(3) unsigned NOT NULL default 0,
+ `key` varchar(32) default NULL,
+ `data` text default NULL,
+ PRIMARY KEY (`chan`, `type`, `key`)
+) ENGINE=MyISAM;
+
+DROP TABLE IF EXISTS `chanuser`;
+CREATE TABLE `chanuser` (
+ `seq` mediumint(8) unsigned NOT NULL default '0',
+ `nickid` int(11) unsigned NOT NULL default '0',
+ `chan` char(32) NOT NULL default '',
+ `joined` tinyint(3) unsigned NOT NULL default '0',
+ `op` tinyint(4) NOT NULL default '0',
+ PRIMARY KEY (`nickid`,`chan`),
+ KEY `chan` (`chan`),
+ KEY `nickid` (`nickid`)
+) ENGINE=HEAP;
+
+DROP TABLE IF EXISTS `nickchg`;
+CREATE TABLE `nickchg` (
+ `seq` mediumint(8) unsigned NOT NULL default '0',
+ `nickid` int(11) unsigned NOT NULL default '0',
+ `nick` char(30) NOT NULL default '',
+ PRIMARY KEY (`nick`)
+) ENGINE=HEAP;
+
+DROP TABLE IF EXISTS `tklban`;
+CREATE TABLE `tklban` (
+ `type` char(1) NOT NULL default '',
+ `ident` char(10) NOT NULL default '',
+ `host` char(64) NOT NULL default '',
+ `setter` char(106) NOT NULL default '',
+ `expire` int(11) unsigned NOT NULL default 0,
+ `time` int(11) unsigned NOT NULL default 0,
+ `reason` char(255) NOT NULL default '',
+ PRIMARY KEY (`type`, `ident`, `host`)
+) ENGINE = HEAP;
+
+DROP TABLE IF EXISTS `spamfilter`;
+CREATE TABLE `spamfilter` (
+ `target` char(20) NOT NULL default '',
+ `action` char(20) NOT NULL default '',
+ `setter` char(106) NOT NULL default '',
+ `expire` int(11) unsigned NOT NULL default 0,
+ `time` int(11) unsigned NOT NULL default 0,
+ `bantime` int(11) unsigned NOT NULL default 0,
+ `reason` char(255) NOT NULL default '',
+ `mask` char(255) NOT NULL default '',
+ PRIMARY KEY (`target`, `action`, `mask`)
+) ENGINE = HEAP;
+
+# Keep this even though it is volatile; it still contains useful data
+CREATE TABLE `user` (
+ `id` int(11) unsigned NOT NULL default '0',
+ `nick` char(30) NOT NULL default '',
+ `time` int(11) unsigned NOT NULL default '0',
+ `inval` tinyint(4) NOT NULL default '0',
+ `ident` char(10) NOT NULL default '',
+ `host` char(64) NOT NULL default '',
+ `vhost` char(64) NOT NULL default '',
+ `cloakhost` char(64) default NULL,
+ `ip` int(8) unsigned NOT NULL default '0',
+ `server` char(64) NOT NULL default '',
+ `modes` char(30) NOT NULL default '',
+ `gecos` char(50) NOT NULL default '',
+ `guest` tinyint(1) NOT NULL default '0',
+ `online` tinyint(1) unsigned NOT NULL default '0',
+ `quittime` int(11) unsigned NOT NULL default '0',
+ `flood` tinyint(1) unsigned NOT NULL default '0',
+ `flags` mediumint(10) unsigned NOT NULL,
+ PRIMARY KEY (`id`),
+ UNIQUE KEY `nick` (`nick`),
+ KEY `ip` (`ip`)
+) ENGINE=HEAP;
+
+#################################################
+# Not used
+
+DROP TABLE IF EXISTS `olduser`;
+
+DROP TABLE IF EXISTS `chanlog`;
+#CREATE TABLE `chanlog` (
+# `chan` char(30) NOT NULL default '',
+# `adder` char(30) NOT NULL default '',
+# `time` unsigned int NOT NULL default 0,
+# `email` varchar(100) NOT NULL default ''
+# PRIMARY KEY (`chan`)
+#) ENGINE = MyISAM;
+
+#################################################
+# Upgrades
+
+# 0.4.2
+ALTER TABLE chanperm MODIFY `name` char(16) NOT NULL default '';
+UPDATE chanperm SET name='AkickEnforce' WHERE name LIKE 'AkickEn%';
+ALTER TABLE `ms_ignore` DROP KEY `nickid`, DROP COLUMN id;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use IO::Socket;
+use Time::HiRes qw(gettimeofday);
+my $socket = IO::Socket::INET->new(PeerAddr => '127.0.0.1',
+ PeerPort => 7000,
+ Proto => "tcp")
+ or die "Couldn't connect to localhost:7000 : $@\n";
+$socket->autoflush(1);
+&connected;
+my @serverlist;
+my %users;
+while ( <$socket> ) {
+ print "-> $_";
+ parsemsg($_);
+}
+
+sub connected {
+ # SERVER servername password hopcount id :description
+ print $socket "SERVER services.test.net polarbears 0 00A :Services \n";
+}
+sub parsemsg {
+ my $msg = $_;
+ $msg =~ s/[\r\n]//g;
+ if ($msg =~ /^SERVER (.*) (.*) (.*) (.*) :(.+)/) {
+ push @serverlist, $4;
+ ircsend(":00A BURST");
+ ircsend(":services.test.net VERSION :SurrealServices 00A");
+ ircsend(":00A UID 00AAAAAAB ".time." NickServ services.test.net services.test.net NickServ 0.0.0.0 ".time." +io :Nickname Services");
+ ircsend(":00AAAAAAB OPERTYPE Services");
+ ircsend(":00A UID 00AAAAAAC ".time." ChanServ services.test.net services.test.net ChanServ 0.0.0.0 ".time." +io :Channel Services");
+ ircsend(":00AAAAAAC OPERTYPE Services");
+ ircsend(":00A UID 00AAAAAAD ".time." MemoServ services.test.net services.test.net MemoServ 0.0.0.0 ".time." +io :Memo Services");
+ ircsend(":00AAAAAAD OPERTYPE Services");
+ ircsend(":00A UID 00AAAAAAE ".time." OperServ services.test.net services.test.net OperServ 0.0.0.0 ".time." +io :Oper Services");
+ ircsend(":00AAAAAAE OPERTYPE Services");
+ ircsend(":00A ENDBURST");
+ ircsend(":00A PING 00A $serverlist[0]");
+ }
+ if ($msg =~ /^:(.*) PING (.*) (.*)$/) {
+ if ($1 eq $serverlist[0]) {
+ ircsend(":00A PONG 00A $serverlist[0]");
+ }
+ }
+ if ($msg =~ /^:(.*) FJOIN (.*) (.*) (.+) :?(.+)$/) {
+ parse_fjoin($1,$2,$3,$4,$5);
+ }
+ if ($msg =~ /^:(.*) IDLE (.*)$/) {
+ parse_idle($1,$2);
+ }
+ if ($msg =~ /^:(.*) UID (\S+) (\d+) (\S+) (\S+) (\S+) (\S+) (\S+) (\S+) (.+) :(.+)$/) {
+ parse_uid($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11);
+ }
+ if ($msg =~ /^:(.*) PRIVMSG (\S+) :(.+)$/) {
+ parse_privmsg($1,$2,$3);
+ }
+}
+sub ircsend {
+ my $msg = shift;
+ print "<- $msg\n";
+ $msg .= " \n";
+ print $socket $msg;
+}
+
+sub parse_fjoin {
+ #:431 FJOIN #test 1246571540 +nt :,431AAAAAC ,431AAAAAA
+ my ($src, $chan, $ts, $modes, $users) = @_;
+ if ($chan eq "#test") {
+ print "!!! aa - $modes\n";
+ ircsend(":00A FJOIN $chan $ts $modes :o,00AAAAAAB o,00AAAAAAC o,00AAAAAAD o,00AAAAAAE");
+ }
+}
+sub parse_idle {
+ my ($src, $target) = @_;
+ ircsend(":$target IDLE $users{$src}{'nick'} ".time." 0");
+}
+sub parse_uid {
+ #:431 UID 431AAAAAA 1246349244 MusashiX90 127.0.0.1 netadmin.omega.org.za nano 127.0.0.1 1246349249 +Wios +ACJKLNOQacdfgjklnoqtx :mwt
+ my ($src, $uid, $ts, $nick, $hostname, $cloak, $ident, $ip, $signon, $modes, $realname) = @_;
+ print "DEBUG: Added '$nick' to users\n";
+ $users{$uid}{'nick'} = $nick;
+}
+
+sub parse_privmsg {
+ my ($src, $target, $msg) = @_;
+ # PRIVMSG sent to MemoServ
+ if ($target eq "00AAAAAAD") {
+ ircsend(":$target NOTICE $src :Received your message");
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use MIME::Base64 qw( decode_base64 encode_base64 );
+use Socket;
+use Socket6;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename qw( dirname );
+ use constant { PREFIX => abs_path(dirname(abs_path($0)).'/../') };
+}
+use lib PREFIX;
+
+use SrSv::Conf::main;
+use SrSv::IPv6;
+
+my $IPstring = 'AAAAAAAAAAAAAAAAAAAAAQ==';
+my $IPstring2 = 'CgECgw==';
+my $IPstring3 = 'IAEZOAJdvu8AAAAAAAEABA';
+
+#print length(decode_base64($IPstring)), "\n", length(decode_base64($IPstring2)), "\n";
+#exit;
+#print Socket6::inet_ntop(AF_INET6, decode_base64($IPstring)), "\n";
+#print Socket6::inet_ntop(AF_INET, decode_base64($IPstring2)), "\n";
+print Socket6::inet_ntop(AF_INET6, decode_base64($IPstring3)), "\n";
+print get_ipv6_net(Socket6::inet_ntop(AF_INET6, decode_base64($IPstring3))), "\n";
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename qw( dirname );
+ use constant { PREFIX => abs_path(dirname(abs_path($0)).'/../') }
+}
+use lib PREFIX;
+
+use libs::misc;
+use SrSv::Util qw(say seqifyList makeSeqList);
+
+#say makeSeqList(92..99,1..3,5..9,);
+#say seqifyList(92..99,1..3,5..9,);
+say seqifyList(makeSeqList(92..99,1..3,5..9,10,11));
--- /dev/null
+#!/usr/bin/perl
+
+sub say(@) {
+ print map({ "$_\n" } @_);
+}
+use strict;
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename qw( dirname );
+ use constant { PREFIX => abs_path(dirname(abs_path($0)).'/../') }
+}
+use lib PREFIX;
+
+#use Digest::SHA::PurePerl;
+use SrSv::Hash::SaltedHash qw( makeHash_v0 makeHash verifyHash extractMeta extractSalt );
+
+#say makeHash_v0('fumafuma', 'fufu', 'SHA256');
+#exit;
+
+my ($algorithm, $version, $salt) = extractMeta('{SSHA}zIdhML+axPWmpSymzKlTciJ5asoryacr');
+my $hash = makeHash_v0('choice81', $salt, $algorithm);
+say $hash;
+exit;
+my $check = verifyHash($hash, 'fumafuma');
+print (($check ? 'true' : 'false')."\n");
+
+#my $hash = makeHash_v0('fumafuma');
+#my ($algo, $version, $salt) = extractMeta($hash);
+#say "$algo $version $salt";
+#say length(makeHash_v0('fumafuma', 'fufu', 'SHA256'));
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename qw( dirname );
+ use constant { PREFIX => abs_path(dirname(abs_path($0)).'/../') }
+}
+use lib PREFIX;
+
+use SrSv::Time;
+
+my ($weeks, $days, $hours, $minutes, $seconds) = split_time(103.2);
+
+print "$minutes $seconds\n";
--- /dev/null
+/*
+ * NEW: alias {}
+ * OLD: N/A
+ * This allows you to set command aliases such as /identify, /services, etc
+ *
+ * Syntax:
+ * alias "name" {
+ * format "format string" {
+ * nick "points to";
+ * type aliastype;
+ * parameters "parameters to send";
+ * };
+ * type command;
+ * };
+ */
+/* This is shown seperately because even though it has the same name as the previous directive, it is very
+ * different in syntax, although it provides a similar function and relys on the standard aliases to work.
+ */
+include "config/net/aliases/genericservices.conf";
+include "config/net/aliases/surrealservices.conf";
+include "config/net/aliases/ircd.conf";
+
--- /dev/null
+/* Standard Aliases */
+
+alias identify {
+/* format "^#" {
+ nick chanserv;
+ type services;
+ parameters "IDENTIFY %1-";
+ };*/
+ format "^[^#]" {
+ nick nickserv;
+ type services;
+ parameters "IDENTIFY %1-";
+ };
+ type command;
+};
+
+alias id {
+/* format "^#" {
+ nick chanserv;
+ type services;
+ parameters "IDENTIFY %1-";
+ };*/
+ format "^[^#]" {
+ nick nickserv;
+ type services;
+ parameters "IDENTIFY %1-";
+ };
+ type command;
+};
+
+alias services {
+ format "^#" {
+ nick chanserv;
+ type services;
+ parameters "%1-";
+ };
+ format "^[^#]" {
+ nick nickserv;
+ type services;
+ parameters "%1-";
+ };
+ type command;
+ spamfilter yes;
+};
+
+alias register {
+ format "^#" {
+ nick chanserv;
+ type services;
+ parameters "REGISTER %1-";
+ };
+ format "^[^#]" {
+ nick nickserv;
+ type services;
+ parameters "REGISTER %1-";
+ };
+ type command;
+};
--- /dev/null
+alias umode {
+ format "" {
+ command "MODE";
+ type real;
+ parameters "%n %1-";
+ };
+ type command;
+};
--- /dev/null
+/* SurrealServices Aliases */
+
+alias nickserv { type services; };
+alias ns { target nickserv; type services; spamfilter yes; };
+
+alias chanserv { type services; spamfilter yes; };
+alias cs { target chanserv; type services; spamfilter yes; };
+
+alias memoserv { type services; spamfilter yes; };
+alias ms { target memoserv; type services; spamfilter yes; };
+
+alias hostserv { type services; };
+alias hs { target hostserv; type services; };
+
+alias operserv { type services; };
+alias os { target operserv; type services; };
+
+alias rootserv { target servserv; type services; };
+/* alias rs { target servserv; type services; }; */
+
+alias botserv { type services; spamfilter yes; };
+alias bs { target botserv; type services; spamfilter yes; };
+
+alias adminserv { target adminserv; type services; };
+alias as { target adminserv; type services; };
+
+alias uinfo {
+ format "" { // basically anything can be fed to this alias, tho we only want nicks
+ nick operserv;
+ type services;
+ parameters "UINFO %1-";
+ };
+ type command;
+};
+
+alias seen {
+ format "" { // basically anything can be fed to this alias, tho we only want nicks
+ nick nickserv;
+ type services;
+ parameters "SEEN %1-";
+ };
+ type command;
+};
+
+alias fjoin {
+ format "" {
+ nick operserv;
+ type services;
+ parameters "FJOIN %1-";
+ };
+ type command;
+};
+
+alias fpart {
+ format "" {
+ nick operserv;
+ type services;
+ parameters "FPART %1-";
+ };
+ type command;
+};
+
+alias gnick {
+ format "" {
+ nick operserv;
+ type services;
+ parameters "GNICK %1-";
+ };
+ type command;
+};
+
+alias mkill {
+ format "" {
+ nick operserv;
+ type services;
+ parameters "CLONES KILL %1-"; // this should become MASSKILL when SrSv 0.4.2 goes -final
+ };
+ type command;
+};
+
+alias masskill {
+ format "" {
+ nick operserv;
+ type services;
+ parameters "CLONES KILL %1-";
+ };
+ type command;
+};
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+use File::stat;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+chdir PREFIX;
+use lib PREFIX;
+
+use SrSv::Time;
+
+my $logdir = PREFIX.'/logs';
+my $chanlogdir = "$logdir/chanlogs";
+my $gzip = qx(which gzip);
+my $bzip2 = qx(which bzip2);
+chomp ($gzip, $bzip2);
+# greater than 1000 bytes, bzip2, else gzip.
+# This is based on an average observed from chanlogs.
+# Thankfully bzcat and bzgrep tend to be agnostic.
+my $bzip_threshold = 1000;
+# if less than 100 bytes, don't bother to gzip.
+my $gzip_threshold = 100;
+
+opendir ((my $LOGDIR), $logdir.'/');
+
+my $i = 0; my @today = gmt_date();
+while (my $filename = readdir($LOGDIR)) {
+ next if $filename eq '..' or $filename =~ /\.(gz|bz2)$/ or !(-f "$logdir/$filename");
+ my $dir; my ($year, $month, $day);
+ if($filename =~ /^services.log-(\d{4})-(\d{2})-(\d{2})$/i) {
+ ($year, $month, $day) = ($1, $2, $3);
+ if($year == $today[0] and $month == $today[1] and $day == $today[3]) {
+ # Don't process today's logs
+ print "Skipping $filename\n";
+ next;
+ }
+
+ $dir = $logdir;
+ }
+ elsif ($filename =~ /^#.*\.log-(\d{4})-(\d{2})-(\d{2})$/i) {
+ ($year, $month, $day) = ($1, $2, $3);
+ if($year == $today[0] and $month == $today[1] and $day == $today[3]) {
+ # Don't process today's logs
+ print "Skipping $filename\n";
+ next;
+ }
+ # Eventual plan is to make these available on the website...
+ # This may necessitate only using gzip however (mod_deflate)
+
+ $dir = $chanlogdir;
+ mkdir $chanlogdir unless (-d $chanlogdir);
+
+ }
+ else { next; }
+ # rename() is 'move', or really link($newname) and unlink($oldname)
+ unless(-d "$dir/$year/$month") {
+ mkdir "$dir/$year" unless (-d "$dir/$year");
+ mkdir "$dir/$year/$month";
+ }
+ rename "$logdir/$filename", "$dir/$year/$month/$filename";
+ compressFile("$dir/$year/$month/$filename");
+ $i++;
+}
+
+sub compressFile($) {
+ my ($file) = @_;
+ my $fileStat = stat($file);
+ my $fileSize = $fileStat->[7];
+ my $compressor;
+ if($fileSize > $bzip_threshold) {
+ $compressor = $bzip2;
+ } elsif($fileSize < $gzip_threshold) {
+ return;
+ } else {
+ $compressor = $gzip;
+ }
+ system($compressor, '-9vv', $file);
+}
+closedir $LOGDIR;
+
+print "Processed $i logs\n";
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# SurrealChat.net does not provide the Blacklist Data
+# is in no way associated with dronebl.org,
+# nor are we providing a license to download/use it.
+# Be sure to direct availability/accuracy/licensing questions to
+# http://dronebl.org/docs/howtouse
+
+use strict;
+use DBI;
+use Cwd 'abs_path';
+use File::Basename;
+
+use Cwd qw( abs_path getcwd );
+use File::Basename qw( dirname );
+BEGIN {
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/../'),
+ );
+ require constant; import constant \%constants;
+}
+use lib PREFIX;
+
+#Date::Parse might not be on the user's system, so we ship our own copy.
+use Date::Parse;
+
+use SrSv::SimpleHash qw(readHash);
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts 'sql';
+
+my $srcname = 'http://dronebl.org/buildzone.do';
+my $bindip = undef;
+my $unpackname = $srcname;
+my $diffname = $srcname.'.diff';
+my $agent = findAgent();
+
+sub findAgent {
+ my $agent;
+ my $ret = system('which curl');
+ if(($ret >> 8) == 0) {
+ # we prefer curl b/c it can handle gzip compression!
+ # we do IPv4 b/c either their IPv6 gateway or ours is SLOW
+ # UPDATE 2011/05: due to DDoS, IPv4 is swamped, IPv6 is only way!
+ $agent = 'curl --compressed --silent';
+ } else {
+ $agent = 'wget -q -O -';
+ }
+ return $agent;
+}
+
+my $OPMDATA;
+unless(open $OPMDATA, '-|', "$agent $srcname") {
+ print STDERR "FATAL: Processing failed.\n";
+ exit -1;
+}
+
+print "Connecting to database...\n";
+
+my $dbh;
+eval {
+ $dbh = DBI->connect("DBI:mysql:".sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass,
+ { AutoCommit => 1, RaiseError => 1, PrintError => 1 })
+};
+
+if($@) {
+ print STDERR "FATAL: Can't connect to database:\n$@\n";
+ print STDERR "You must have SrSv properly setup before you attempt to use this helper script.\n\n";
+ exit -1;
+}
+
+print "Creating new table...\n";
+
+$dbh->do("DROP TABLE IF EXISTS `newopm`");
+$dbh->do(
+"CREATE TEMPORARY TABLE `newopm` (
+ `ipnum` int(11) unsigned NOT NULL default 0,
+ `ipaddr` char(15) NOT NULL default '0.0.0.0',
+ `type` tinyint(3) NOT NULL default 0,
+ PRIMARY KEY (`ipnum`),
+ UNIQUE KEY `addrkey` (`ipaddr`)
+) Engine=Memory;"
+);
+
+sub save2DB($@) {
+ my ($baseQuery, @rows) = @_;
+ $dbh->do("$baseQuery ".join(',', @rows));
+}
+
+sub processData() {
+ print "Inserting data... ";
+
+ $dbh->do("ALTER TABLE `newopm` DISABLE KEYS");
+ $dbh->do("LOCK TABLES `newopm` WRITE");
+ my $type;
+ my $baseQuery = "REPLACE INTO `newopm` (ipnum, ipaddr, type) VALUES ";
+ my @rows;
+ my $count = 0;
+ while(my $x = <$OPMDATA>) {
+ chomp $x;
+ if($x =~ /^:(\d{1,3}):/) {
+ $type = $1;
+ } elsif($x =~ /^(\d+\.\d+\.\d+\.\d+)$/) {
+ next unless $type;
+ my $ipaddr = $1;
+ push @rows, '(INET_ATON('.$dbh->quote($ipaddr).'),'.$dbh->quote($ipaddr).','.$type.')';
+ $count++;
+ if(scalar(@rows) > 1000) {
+ save2DB($baseQuery, @rows);
+ @rows = ();
+ }
+ }
+ }
+ die "No entries found\n" unless $count;
+
+ #rename($unpackname, $srcname.'.old');
+ save2DB($baseQuery, @rows) if scalar(@rows);
+
+ $dbh->do("UNLOCK TABLES");
+ $dbh->do("ALTER TABLE `newopm` ENABLE KEYS");
+}
+
+processData();
+close $OPMDATA;
+
+print "done.\nRemoving old table...\n";
+$dbh->do("DROP TABLE IF EXISTS `oldopm`");
+$dbh->do("ALTER TABLE opm ENGINE=InnoDB");
+$dbh->do("START TRANSACTION");
+print "Renaming new table...\n";
+#$dbh->{RaiseError} = $dbh->{PrintError} = 0; # the following commands can fail, but are harmless.
+$dbh->do("TRUNCATE TABLE `opm`");
+$dbh->do("INSERT INTO opm SELECT * FROM newopm");
+$dbh->do("COMMIT");
+
+print "Blacklist table update complete.\n";
+
+exit;
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# SurrealChat.net does not provide the Country/Allocation data,
+# is in no way associated with ludost.net,
+# nor are we providing a license to download/use it.
+# Be sure to direct availability/accuracy/licensing questions to ludost.net
+use strict;
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+chdir PREFIX;
+use lib PREFIX;
+
+use Date::Parse;
+
+use SrSv::Conf 'sql';
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts qw( sql );
+
+my $countrydb_url= 'http://ip.ludost.net/raw/country.db.gz';
+my $srcname = 'country.db.gz';
+my $unpackname = 'country.db';
+
+main();
+
+sub main() {
+ downloadData();
+ print "Connecting to database...\n";
+ my $dbh = dbConnect();
+ newTable($dbh);
+ print "Inserting data... ";
+ loadData($dbh);
+ print "Removing old table...\n";
+ cleanup($dbh);
+ $dbh->disconnect();
+ print "Country table update complete.\n";
+
+ unlink PREFIX."/data/$unpackname";
+
+ exit;
+}
+
+sub downloadData() {
+ # This MAY be implementable with an open of a pipe
+ # pipe the output of wget through gzip -d
+ # and then into the load-loop.
+ # It's a bit heavy to run directly from inside services however.
+ # I'd recommend it be run as a crontab script separate from services.
+
+ my (@stats, $date, $size);
+ if(@stats = stat(PREFIX."/data/$srcname")) {
+ print "Checking for updated country data...\n";
+ my $header = qx{wget --spider -S $countrydb_url 2>&1};
+ ($date) = ($header =~ /Last-Modified: (.*)/);
+ ($size) = ($header =~ /Content-Length: (.*)/);
+ }
+
+ if(@stats and $stats[7] == $size and $stats[9] >= str2time($date)) {
+ print "Country data is up to date.\n";
+ } else {
+ print "Downloading country data...\n";
+
+ unlink PREFIX."/data/$srcname";
+ system("wget $countrydb_url -O ".PREFIX."/data/$srcname");
+ unless(-e PREFIX."/data/$srcname") {
+ print STDERR "FATAL: Download failed.\n";
+ exit -1;
+ }
+ }
+
+ print "Decompressing...\n";
+ unlink PREFIX."/data/$unpackname";
+ system("gunzip -c ".PREFIX."/data/$srcname > ".PREFIX."/data/$unpackname");
+ unless(-e PREFIX."/data/$unpackname") {
+ print STDERR "FATAL: Decompression failed.\n";
+ exit -1;
+ }
+}
+
+sub dbConnect() {
+ my $dbh;
+ eval {
+ $dbh = DBI->connect("DBI:mysql:".sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass,
+ { AutoCommit => 1, RaiseError => 1 })
+ };
+
+ if($@) {
+ print STDERR "FATAL: Can't connect to database:\n$@\n";
+ print STDERR "You must edit config/sql.conf and create a corresponding\nMySQL user and database!\n\n";
+ exit -1;
+ }
+
+ print "Creating new table...\n";
+
+ $dbh->{RaiseError} = 1;
+ $dbh->{PrintError} = 1;
+ return $dbh;
+}
+
+sub newTable($) {
+ my ($dbh) = @_;
+
+ $dbh->do("DROP TABLE IF EXISTS newcountry");
+ $dbh->do(
+ "CREATE TABLE `newcountry` (
+ `low` int unsigned NOT NULL default 0,
+ `high` int unsigned NOT NULL default 0,
+ `country` char(2) NOT NULL default '-',
+ PRIMARY KEY (`low`, `high`)
+ ) TYPE=MyISAM"
+ );
+}
+
+sub loadData($) {
+ my ($dbh) = @_;
+
+ my $add_entry = $dbh->prepare("INSERT INTO newcountry SET low=INET_ATON(?), high=INET_ATON(?), country=?");
+
+ $| = 1;
+ my $unpackFile = PREFIX."/data/$unpackname";
+ my ($lines) = qx{wc -l $unpackFile};
+ my $div = int($lines/100);
+ my ($i, @entries);
+
+ open ((my $COUNTRYTABLE), '<', $unpackFile);
+ $dbh->do("ALTER TABLE `newcountry` DISABLE KEYS");
+ $dbh->do("LOCK TABLES newcountry WRITE");
+ while(my $x = <$COUNTRYTABLE>) {
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+
+ chomp $x;
+ my ($low, $high, $country) = split(/ /, $x);
+ #$add_entry->execute($low, $high, $country);
+ push @entries,
+ '(INET_ATON('.$dbh->quote($low).'),'.'INET_ATON('.$dbh->quote($high).'),'.$dbh->quote($country).')';
+ if (scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
+ $dbh->do("UNLOCK TABLES");
+ $dbh->do("ALTER TABLE `newcountry` ENABLE KEYS");
+ close $COUNTRYTABLE;
+ print "\b\b\b\bdone.\n";
+}
+
+sub cleanup() {
+ my ($dbh) = @_;
+
+ $dbh->do("DROP TABLE IF EXISTS `oldcountry`");
+ print "Renaming new table...\n";
+ $dbh->{RaiseError} = 0;
+ $dbh->do("OPTIMIZE TABLE `newcountry`");
+ $dbh->do("ANALYZE TABLE `newcountry`");
+ # Doing the renames cannot be done atomically
+ # as sometimes `country` doesn't exist yet.
+ $dbh->do("RENAME TABLE `country` TO `oldcountry`");
+ $dbh->do("RENAME TABLE `newcountry` TO `country`");
+ $dbh->do("DROP TABLE `oldcountry`");
+}
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# SurrealChat.net does not provide the Country/Allocation data,
+# is in no way associated with maxmind.com,
+# nor are we providing a license to download/use it.
+# Be sure to direct availability/accuracy/licensing questions to maxmind.com
+
+use strict;
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+chdir PREFIX;
+use lib PREFIX;
+
+use Date::Parse;
+
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts qw( sql );
+
+use constant {
+ countrydb_url => 'http://www.maxmind.com/download/geoip/database/GeoIPCountryCSV.zip',
+ #countrydb_url => 'http://www.tabris.net/tmp/GeoIPCountryCSV.zip',
+ srcname => 'GeoIPCountryCSV.zip',
+ unpackname => 'GeoIPCountryWhois.csv',
+};
+
+main();
+exit 0;
+
+sub main() {
+ downloadData();
+ print "Connecting to database...\n";
+ my $dbh = dbConnect();
+ print "Creating new table...\n";
+ newTable($dbh);
+ print "Inserting data... ";
+ loadData($dbh);
+ cleanup($dbh);
+ $dbh->disconnect();
+ print "Country table update complete.\n";
+}
+
+sub downloadData() {
+ # This MAY be implementable with an open of a pipe
+ # pipe the output of wget through gzip -d
+ # and then into the load-loop.
+ # It's a bit heavy to run directly from inside services however.
+ # I'd recommend it be run as a crontab script separate from services.
+
+ my (@stats, $date, $size);
+ my $srcPath = PREFIX.'/data/'.srcname;
+ if(@stats = stat($srcPath)) {
+ print "Checking for updated country data...\n";
+ my $header = qx "wget --spider -S ".countrydb_url." 2>&1";
+ ($date) = ($header =~ /Last-Modified: (.*)/);
+ ($size) = ($header =~ /Content-Length: (.*)/);
+ }
+
+ if(@stats and $stats[7] == $size and $stats[9] >= str2time($date)) {
+ print "Country data is up to date.\n";
+ } else {
+ print "Downloading country data...\n";
+
+ unlink $srcPath;
+ system('wget '.countrydb_url." -O $srcPath");
+ unless(-e $srcPath) {
+ print STDERR "FATAL: Download failed.\n";
+ exit;
+ }
+ }
+
+ my $unpackPath = PREFIX.'/data/'.unpackname;
+ print "Decompressing...\n";
+ unlink $unpackPath;
+ system("unzip $srcPath -d ".PREFIX.'/data/');
+ unless(-f $unpackPath) {
+ print STDERR "FATAL: Decompression failed.\n";
+ exit;
+ }
+}
+
+sub dbConnect() {
+ my $dbh;
+ eval {
+ $dbh = DBI->connect("DBI:mysql:".sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass,
+ { AutoCommit => 1, RaiseError => 1 })
+ };
+
+ if($@) {
+ print STDERR "FATAL: Can't connect to database:\n$@\n";
+ print STDERR "You must edit config/sql.conf and create a corresponding\nMySQL user and database!\n\n";
+ exit -1;
+ }
+ return $dbh;
+}
+
+sub newTable($) {
+ my ($dbh) = @_;
+ $dbh->{RaiseError} = 1;
+ $dbh->{PrintError} = 1;
+
+ $dbh->do("DROP TABLE IF EXISTS newcountry");
+ $dbh->do(
+ "CREATE TABLE `newcountry` (
+ `low` int unsigned NOT NULL default 0,
+ `high` int unsigned NOT NULL default 0,
+ `country` char(2) NOT NULL default '-',
+ PRIMARY KEY (`low`, `high`)
+ ) TYPE=MyISAM"
+ );
+}
+
+sub loadData($) {
+ my ($dbh) = @_;
+ $| = 1;
+ my $unpackPath = PREFIX.'/data/'.unpackname;
+ my ($lines) = qx{wc -l $unpackPath};
+ my $div = int($lines/100);
+ my ($i, @entries);
+
+ open ((my $COUNTRYTABLE), '<', $unpackPath);
+ my $add_entry = $dbh->prepare("INSERT INTO newcountry SET low=INET_ATON(?), high=INET_ATON(?), country=?");
+ $dbh->do("ALTER TABLE `newcountry` DISABLE KEYS");
+ $dbh->do("LOCK TABLES newcountry WRITE");
+ while(my $x = <$COUNTRYTABLE>) {
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+
+ chomp $x;
+ #"2.6.190.56","2.6.190.63","33996344","33996351","GB","United Kingdom"
+ #$x =~ /\"(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\"\,\"(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\"\,\"(\d+)\"\,\"(\d+)\"\,\"\w{2}\",\"(.+)\"/;
+ $x =~ s/\"//g;
+ my ($low, $high, undef, undef, $country, undef) = split(',', $x);
+ #$add_entry->execute($low, $high, $country);
+ push @entries,
+ '(INET_ATON('.$dbh->quote($low).'),'.'INET_ATON('.$dbh->quote($high).'),'.$dbh->quote($country).')';
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
+ $dbh->do("UNLOCK TABLES");
+ $dbh->do("ALTER TABLE `newcountry` ENABLE KEYS");
+ close $COUNTRYTABLE;
+}
+
+sub cleanup($) {
+ my ($dbh) = @_;
+
+ print "\b\b\b\bdone.\nRemoving old table...\n";
+ $dbh->do("DROP TABLE IF EXISTS `oldcountry`");
+ print "Renaming new table...\n";
+ $dbh->{RaiseError} = 0;
+ $dbh->do("OPTIMIZE TABLE `newcountry`");
+ $dbh->do("ANALYZE TABLE `newcountry`");
+ # Doing the renames cannot be done atomically
+ # as sometimes `country` doesn't exist yet.
+ $dbh->do("RENAME TABLE `country` TO `oldcountry`");
+ $dbh->do("RENAME TABLE `newcountry` TO `country`");
+ $dbh->do("DROP TABLE `oldcountry`");
+ unlink PREFIX.'/data/'.unpackname;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# SurrealChat.net does not provide the Country/Allocation data,
+# is in no way associated with maxmind.com,
+# nor are we providing a license to download/use it.
+# Be sure to direct availability/accuracy/licensing questions to maxmind.com
+
+use strict;
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+chdir PREFIX;
+use lib PREFIX;
+
+use Date::Parse;
+
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts qw( sql );
+
+use constant {
+ countrydb_url => 'rsync://countries-ns.mdc.dk/zone/zz.countries.nerd.dk.rbldnsd',
+ srcname => 'zz.countries.nerd.dk.rbldnsd',
+};
+
+main();
+exit 0;
+
+sub main() {
+
+ print "Synching country-data file...\n";
+ downloadData();
+ print "Connecting to database...\n";
+ my $dbh = dbConnect();
+ print "Creating new table...\n";
+ newTable($dbh);
+ print "Inserting data... ";
+ loadData($dbh);
+ print "Removing old table...\n";
+ cleanup($dbh);
+ $dbh->disconnect();
+ print "Country table update complete.\n";
+}
+
+sub downloadData() {
+ my $srcPath = PREFIX.'/data/'.srcname;
+ system('rsync -azvv --progress '.countrydb_url.' '.$srcPath);
+ unless(-e $srcPath) {
+ print STDERR "FATAL: Download failed.\n";
+ exit -1;
+ }
+}
+
+sub dbConnect() {
+
+ my $dbh;
+ eval {
+ $dbh = DBI->connect("DBI:mysql:"..sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass,
+ { AutoCommit => 1, RaiseError => 1, PrintError => 1 })
+ };
+
+ if($@) {
+ print STDERR "FATAL: Can't connect to database:\n$@\n";
+ print STDERR "You must edit config/sql.conf and create a corresponding\nMySQL user and database!\n\n";
+ exit -1;
+ }
+ return $dbh;
+}
+
+
+sub newTable($) {
+ my ($dbh) = @_;
+
+ $dbh->do("DROP TABLE IF EXISTS newcountry");
+ $dbh->do(
+ "CREATE TABLE `newcountry` (
+ `low` int unsigned NOT NULL default 0,
+ `high` int unsigned NOT NULL default 0,
+ `country` char(2) NOT NULL default '-',
+ PRIMARY KEY (`low`, `high`)
+ ) TYPE=MyISAM"
+ );
+}
+
+sub loadData($) {
+ my ($dbh) = @_;
+ my $add_entry = $dbh->prepare("INSERT IGNORE INTO newcountry SET low=?, high=?, country=?");
+
+ $| = 1;
+ my $unpackPath = PREFIX.'/data/'.srcname;
+ my ($lines) = qx{wc -l $unpackPath};
+ my $div = int($lines/100);
+ my ($i, @entries);
+
+ open ((my $COUNTRYTABLE), '<', $unpackPath);
+ $dbh->do("ALTER TABLE `newcountry` DISABLE KEYS");
+ $dbh->do("LOCK TABLES newcountry WRITE");
+ while(my $x = <$COUNTRYTABLE>) {
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+
+ chomp $x;
+ #85.10.224.152/29 :127.0.0.20:ad
+ if ($x =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\/(\d{1,2}) \:(\S+)\:([a-z]{1,2})$/) {
+ my $low = $1 << 24 | $2 << 16 | $3 << 8 | $4;
+ my $high = $low + ((2 << (31 - $5)));
+ my $country = $7;
+ next if lc $country eq 'eu';
+ push @entries, '('.$dbh->quote($low).','.$dbh->quote($high).','.$dbh->quote($country).')';
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries));
+ @entries = ();
+ }
+ }
+
+ $i++;
+ }
+ $dbh->do("INSERT IGNORE INTO newcountry (low, high, country) VALUES ".join(',', @entries)) if scalar(@entries);
+
+ $dbh->do("UNLOCK TABLES");
+ $dbh->do("ALTER TABLE `newcountry` ENABLE KEYS");
+ close $COUNTRYTABLE;
+ print "\b\b\b\bdone.\n";
+}
+
+sub cleanup($) {
+ my ($dbh) = @_;
+
+ $dbh->do("DROP TABLE IF EXISTS `oldcountry`");
+ print "Renaming new table...\n";
+ $dbh->{RaiseError} = 0;
+ $dbh->do("OPTIMIZE TABLE `newcountry`");
+ $dbh->do("ANALYZE TABLE `newcountry`");
+ # Doing the renames cannot be done atomically
+ # as sometimes `country` doesn't exist yet.
+ $dbh->do("RENAME TABLE `country` TO `oldcountry`");
+ $dbh->do("RENAME TABLE `newcountry` TO `country`");
+ $dbh->do("DROP TABLE `oldcountry`");
+}
--- /dev/null
+#!/usr/bin/perl
+
+########################################################################
+# #
+# SurrealServices Database Dumper 0.2.3 #
+# #
+# This was written b/c the mysqldump program we had was broken. #
+# It will be made both stupid enough and generic enough that it may #
+# be used for other databases as well. #
+# #
+# (C) Copyleft tabris@surrealchat.net 2005, 2006 #
+# All rights reversed, All wrongs avenged. #
+# #
+########################################################################
+
+use strict;
+use DBI;
+
+# Add tables to this list to be skipped
+# SrSv wants to skip the country table
+our %skipList = ( 'country' => 1, 'geoip' => 1, 'geolocation' => 1, 'georegion' => 1, 'opm' => 1 );
+
+use constant {
+ DROP_TABLE => 1,
+# Default maximum packet size is 1MB
+# according to the documentation.
+ MAX_PACKET => (512*1024), # 512KiB
+
+ # Set to 1 if you have large tables, say over 32MB
+ # Reduces memory requirements, but will probably be slower.
+ # If set to zero, we fetch the entire table into memory
+ # then dump it.
+ # WARNING: Doing this with hundred megabyte tables
+ # will probably be slow, and possibly DoS your system
+ # with an Out of Memory condition.
+ LARGE_TABLES => 1,
+ # Most of the time, you don't want to preserve the contents
+ # of a MEMORY or HEAP table, since they're just temporary
+ # and would have been lost on a server restart anyway.
+ # Then again, maybe you want to keep them. If so, set this to 0.
+ # This does still save the schema.
+ SKIP_HEAP_DUMP => 0,
+
+ # This should only be used for debugging purposes
+ # as otherwise it throws junk into the output stream
+ VERBOSE => 0,
+};
+
+our $dbh;
+our $prefix;
+
+BEGIN {
+use Cwd qw( abs_path getcwd );
+use File::Basename;
+ $prefix = dirname(dirname(abs_path($0)).'../');
+ chdir $prefix;
+ import constant { PREFIX => $prefix, CWD => getcwd() };
+}
+
+# WARNING: for the generic case, this needs to be adapted
+# Either adapt the config file that you use,
+# or create a static hash table
+sub get_sql_conn {
+# These libs aren't needed for the generic case
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts qw( sql );
+
+ my %MySQL_config = (
+ 'mysql-db' => sql_conf_mysql_db,
+ 'mysql-user' => sql_conf_mysql_user,
+ 'mysql-pass' => sql_conf_mysql_pass
+ );
+
+ $dbh = DBI->connect(
+ "DBI:mysql:".$MySQL_config{'mysql-db'},
+ $MySQL_config{'mysql-user'},
+ $MySQL_config{'mysql-pass'},
+ {
+ AutoCommit => 1,
+ RaiseError => 1
+ }
+ );
+}
+
+sub get_schema($) {
+ my ($table) = @_;
+ my ($l, $column_data);
+ my $get_table = $dbh->prepare("SHOW CREATE TABLE `$table`");
+ $get_table->execute();
+ my $result = $get_table->fetchrow_array;
+ $get_table->finish();
+
+ $l .= "\n--\n-- Table structure for table `$table`\n--\n".
+ "$result;\n";
+ my $get_column_info = $dbh->column_info(undef, undef, $table, '%');
+ $get_column_info->execute();
+ print "\n";
+ while(my $column_info = $get_column_info->fetchrow_hashref()) {
+ print '#'. $table.'.'.$column_info->{COLUMN_NAME} .'(column #'.$column_info->{ORDINAL_POSITION}.')' . ' is type '.$column_info->{TYPE_NAME}."\n" if VERBOSE;
+ $column_data->[$column_info->{ORDINAL_POSITION}] = $column_info;
+ }
+
+ return ($l, $column_data);
+}
+
+sub prepare_output($$) {
+ my ($table, $data) = @_;
+ return "INSERT INTO `$table` VALUES ".$data.";\n";
+}
+
+sub get_data($$) {
+ my ($table, $column_data) = @_;
+ my @lines = ();
+
+ # This is typically faster than a select loop
+ # However, with REALLY BIG tables, it may become a DoS
+ # Due to selecting too much data at once.
+ my $results = $dbh->selectall_arrayref('SELECT * FROM '."`$table`");
+ my $data = '';
+ foreach my $row (@$results) {
+ my $i = 0;
+ foreach my $element (@$row) {
+ if ($column_data->[++$i]->{TYPE_NAME} =~ /^(TEXT|BLOB)$/i and
+ length($element))
+ {
+ $element = '0x' . unpack ('H*', $element);
+ }
+ elsif ($column_data->[$i]->{TYPE_NAME} =~ /int$/i and
+ length($element))
+ {
+ # do nothing
+ } else {
+ $element = $dbh->quote($element);
+ }
+ }
+ my $l = '('.join(',', @$row).')';
+ if ((length($data) + length($l)) > MAX_PACKET) {
+ push @lines, prepare_output($table, $data);
+ $data = $l;
+ } else {
+ if(length($data)) {
+ $data .= ",$l";
+ } else {
+ $data = $l;
+ }
+ }
+ }
+
+ push @lines, prepare_output($table, $data) if length($data);
+ return @lines;
+}
+
+sub get_data_large($$) {
+ my ($table, $column_data) = @_;
+
+ my $data = '';
+ my $query = $dbh->prepare('SELECT * FROM '."`$table`");
+ $query->execute();
+ while (my @row = $query->fetchrow_array) {
+ my $i = 0;
+ foreach my $element (@row) {
+ if ($column_data->[++$i]->{TYPE_NAME} =~ /^(TEXT|BLOB)$/i and
+ length($element))
+ {
+ $element = '0x' . unpack ('H*', $element);
+ }
+ elsif ($column_data->[$i]->{TYPE_NAME} =~ /int$/i and
+ length($element))
+ {
+ # do nothing
+ } else {
+ $element = $dbh->quote($element);
+ }
+ }
+ my $l = '('.join(',', @row).')';
+ if ((length($data) + length($l)) > MAX_PACKET) {
+ print prepare_output($table, $data);
+ $data = $l;
+ } else {
+ if(length($data)) {
+ $data .= ",$l";
+ } else {
+ $data = $l;
+ }
+ }
+ }
+
+ print prepare_output($table, $data) if length($data);
+}
+
+sub do_dump() {
+ my $tables = $dbh->selectcol_arrayref("SHOW TABLES");
+
+ TABLE: foreach my $table (@$tables) {
+ print "DROP TABLE IF EXISTS `$table`;" if DROP_TABLE;
+ my $column_data;
+
+ {
+ my $schema;
+ ($schema, $column_data) = get_schema($table);
+ print $schema."\n";
+ if ((SKIP_HEAP_DUMP) and
+ (($schema =~ /(ENGINE|TYPE)=(HEAP|MEMORY)/)) or ($skipList{lc $table})
+ ) {
+ next TABLE;
+ }
+ }
+
+ print "--\n-- Dumping data for table '$table'\n--\n".
+ "LOCK TABLES `$table` WRITE;\n".
+ "/*!40000 ALTER TABLE `$table` DISABLE KEYS */;\n";
+ if(LARGE_TABLES) {
+ get_data_large($table, $column_data);
+ } else {
+ print join("\n", get_data($table, $column_data));
+ }
+ print "/*!40000 ALTER TABLE `$table` ENABLE KEYS */;\n".
+ "UNLOCK TABLES;\n".
+ "\n";
+ }
+}
+
+get_sql_conn();
+do_dump();
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# SurrealChat.net does not provide the Country/Allocation data,
+# is in no way associated with maxmind.com,
+# nor are we providing a license to download/use it.
+# Be sure to direct availability/accuracy/licensing questions to maxmind.com
+
+use strict;
+#use warnings;
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+#chdir PREFIX;
+use lib PREFIX;
+
+use Date::Parse;
+use Text::ParseWords; # is a standard (in 5.8) module
+use Time::HiRes qw( time );
+
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts qw( sql );
+use SrSv::Util qw( :say );
+use SrSv::Time qw( split_time );
+
+sub runSQL($@) {
+ my ($dbh, @strings) = @_;
+ foreach my $string (@strings) {
+ my $sql;
+ foreach my $x (split($/, $string)) { $sql .= $x unless $x =~ /^(#|--)/ or $x eq "\n"}
+# $dbh->do("START TRANSACTION");
+ my $printError = $dbh->{PrintError};
+ $dbh->{PrintError} = 0;
+ foreach my $line (split(/;/s, $sql)) {
+ next unless length($line);
+ #print "$line\n";
+ eval { $dbh->do($line); };
+ if($@) {
+ $line =~ s/\s{2,}/ /g;
+ $line =~ s/\n//g;
+ print "$line\n";
+ }
+
+ }
+ $dbh->{PrintError} = $printError;
+# $dbh->do("COMMIT");
+ }
+}
+
+BEGIN {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime();
+ $year += 1900;
+ $mon++; # gmtime returns months January=0
+ my $date = sprintf("%04d%02d01", $year, $mon);
+ require constant;
+ import constant {
+ #countrydb_url => 'http://www.maxmind.com/download/geoip/database/GeoIPCountryCSV.zip',
+ #FIXME: This needs a date generator!
+ countrydb_url => "http://www.maxmind.com/download/geoip/database/GeoLiteCity_CSV/GeoLiteCity_${date}.zip",
+ srcname => "GeoLiteCity_${date}.zip",
+ };
+}
+
+sub main() {
+ downloadData();
+ say "Connecting to database...";
+ my $dbh = dbConnect();
+ say "Creating new table...";
+ newTable($dbh);
+ say "Inserting data... ";
+ loadData($dbh);
+ print "Converting geoip table...";
+ convert($dbh);
+ cleanup($dbh);
+ $dbh->disconnect();
+ say "GeoIP update complete.";
+}
+
+main();
+exit 0;
+
+sub downloadData() {
+ # This MAY be implementable with an open of a pipe
+ # pipe the output of wget through gzip -d
+ # and then into the load-loop.
+ # It's a bit heavy to run directly from inside services however.
+ # I'd recommend it be run as a crontab script separate from services.
+
+ #return;
+ my ($stat, $date, $size);
+ my $srcPath = PREFIX.'/data/'.srcname;
+ say $srcPath;
+ use File::stat;
+ if($stat = stat($srcPath)) {
+ print "Checking for updated country data...\n";
+ my $header = qx "wget --spider -S @{[countrydb_url]} 2>&1";
+ ($date) = ($header =~ /Last-Modified: (.*)/);
+ ($size) = ($header =~ /Content-Length: (.*)/);
+ }
+
+ if($stat and $stat->size == $size and $stat->mtime >= str2time($date)) {
+ say "Country data is up to date.";
+ } else {
+# say $stat->size == $size;
+# say $stat->mtime >= str2time($date);
+ say "Downloading country data...";
+# return;
+
+ unlink $srcPath;
+ system('wget '.countrydb_url." -O $srcPath");
+ unless(-e $srcPath) {
+ sayERR "FATAL: Download failed.";
+ exit;
+ }
+ }
+
+ mkdir PREFIX.'/data/GeoIP/';
+ say "Decompressing...";
+ unlink(glob(PREFIX.'/data/GeoIP/Geo*.csv'));
+ system("unzip -j $srcPath -d ".PREFIX.'/data/GeoIP/');
+ unless(-f PREFIX.'/data/GeoIP/GeoLiteCity-Blocks.csv') {
+ sayERR "FATAL: Decompression failed.";
+ exit -1;
+ }
+}
+
+sub dbConnect() {
+ my $dbh;
+ eval {
+ $dbh = DBI->connect("DBI:mysql:".sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass,
+ { AutoCommit => 1, RaiseError => 1 })
+ };
+
+ if($@) {
+ print STDERR "FATAL: Can't connect to database:\n$@\n";
+ print STDERR "You must edit config/sql.conf and create a corresponding\nMySQL user and database!\n\n";
+ exit -1;
+ }
+ return $dbh;
+}
+
+sub newTable($) {
+ my ($dbh) = @_;
+ $dbh->{RaiseError} = 1;
+ $dbh->{PrintError} = 1;
+
+ runSQL($dbh,
+ "DROP TABLE IF EXISTS new_geoip",
+ "CREATE TABLE `new_geoip` (
+ `low` int unsigned NOT NULL,
+ `high` int unsigned NOT NULL,
+ `location` mediumint(8) unsigned NOT NULL,
+ PRIMARY KEY (`low`, `high`)
+ ) Engine=MyISAM",
+
+ "DROP TABLE IF EXISTS new_geolocation",
+ #"locId,country,region,city,postalCode,latitude,longitude,metroCode,areaCode";
+ "CREATE TABLE `new_geolocation` (
+ `id` mediumint(8) unsigned NOT NULL,
+ `country` char(2) NOT NULL default '-',
+ `region` char(2) NOT NULL default '-',
+ `city` varchar(255) NOT NULL default '-',
+ `postalcode` varchar(6) NOT NULL default '-',
+ `latitude` float NOT NULL default 0.0,
+ `longitude` float NOT NULL default 0.0,
+ `metrocode` int unsigned NOT NULL default 0,
+ `areacode` int unsigned NOT NULL default 0,
+ PRIMARY KEY (`id`),
+ KEY `countrykey` (`country`)
+ ) Engine=MyISAM;",
+
+ "DROP TABLE IF EXISTS `new_metrocode`",
+ "CREATE TABLE `new_metrocode` (
+ `id` smallint NOT NULL default 0,
+ `metro` varchar(128) NOT NULL default '',
+ PRIMARY KEY (`id`)
+ ) Engine=MyISAM;",
+
+ "DROP TABLE IF EXISTS `new_geocountry`",
+ #"locId,country,region,city,postalCode,latitude,longitude,metroCode,areaCode";
+ "CREATE TABLE `new_geocountry` (
+ `code` char(2) NOT NULL default '',
+ `country` varchar(255) default '',
+ PRIMARY KEY (`code`)
+ ) Engine=MyISAM;",
+
+ "DROP TABLE IF EXISTS `new_georegion`",
+ #"locId,country,region,city,postalCode,latitude,longitude,metroCode,areaCode";
+ "CREATE TABLE `new_georegion` (
+ `country` char(2) NOT NULL default '',
+ `region` char(2) NOT NULL default '',
+ `name` varchar(255) default '',
+ PRIMARY KEY (`country`, `region`)
+ ) Engine=MyISAM;",
+
+ );
+}
+
+sub timeDiff($$) {
+ my ($time1, $time2) = @_;
+ my ($weeks, $days, $hours, $minutes, $seconds) = split_time($time2 - $time1);
+ return sprintf("%02d:%02.2f", $minutes, $seconds);
+}
+
+sub loadData($) {
+ my ($dbh) = @_;
+ $| = 1;
+=cut
+ my $unpackPath = PREFIX.'/data/'.unpackname;
+ my ($lines) = qx{wc -l $unpackPath};
+ my $div = int($lines/100);
+=cut
+ my ($i, @entries);
+ my $fh;
+ my $table;
+
+ my $time1 = time();
+ print "Loading geoip data...";
+####### geoip #######
+ open ($fh, '<', PREFIX.'/data/GeoIP/GeoLiteCity-Blocks.csv');
+ $table = 'geoip';
+ #my $add_entry = $dbh->prepare("INSERT INTO `new_geoip` (low, high, location) VALUES (?,?,?)");
+ runSQL($dbh,
+ "LOCK TABLES `new_geoip` WRITE, `new_geolocation` WRITE,
+ `new_metrocode` WRITE, `new_georegion` WRITE, `new_geocountry` WRITE",
+ "ALTER TABLE `new_$table` DISABLE KEYS",
+ );
+
+ my $columns = '(low, high, location)';
+ <$fh>; <$fh>; # pop first 2 lines off.
+ my $i = 0;
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = split(',', $x);
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 3;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ print $i," \n";
+ }
+
+ $i++;
+ }
+ $dbh->do(("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries))) if scalar(@entries);
+ $dbh->do("ALTER TABLE `new_$table` ENABLE KEYS");
+ @entries = ();
+ close $fh;
+####### END geoip #######
+ say " Done.";
+ my $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $time1 = time();
+ print "Loading location data...";
+####### locations #######
+ $table = 'geolocation';
+ $columns = "(`id`, `country`, `region`, `city`, `postalcode`, `latitude`, `longitude`, `metrocode`, `areacode`)";
+ open ($fh, '<', PREFIX.'/data/GeoIP/GeoLiteCity-Location.csv');
+
+ $dbh->do("ALTER TABLE `new_$table` DISABLE KEYS");
+
+ <$fh>; <$fh>; # pop first 2 lines off.
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = map( { $dbh->quote($_) } parse_line(",\\s*", 0, $x) );
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 9;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ $dbh->do(("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries))) if scalar(@entries);
+ @entries = ();
+ $dbh->do("ALTER TABLE `new_$table` ENABLE KEYS");
+ close $fh;
+####### END locations #######
+ say " Done.";
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+
+ $time1 = time();
+ print "Loading metrocode data...";
+####### metrocodes #######
+ open ($fh, '<', PREFIX.'/data/GeoIP/metrocodes.txt');
+ $table = 'metrocode';
+ $columns = "(`id`, `metro`)";
+
+ $dbh->do("ALTER TABLE `new_$table` DISABLE KEYS");
+
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = map( { $dbh->quote($_) } split(' ', $x, 2) );
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 2;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ $dbh->do(("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries))) if scalar(@entries);
+ @entries = ();
+ $dbh->do("ALTER TABLE `new_$table` ENABLE KEYS");
+ close $fh;
+####### END metrocodes #######
+ say " Done.";
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $time1 = time();
+ print "Loading region data...";
+####### regions #######
+ $table = 'georegion';
+ $columns = "(`country`, `region`, `name`)";
+
+ $dbh->do("ALTER TABLE `new_$table` DISABLE KEYS");
+ open ($fh, '<', PREFIX.'/data/fips10_4');
+ <$fh>; # pop first line off.
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = map( { $dbh->quote($_) } parse_line(",\\s*", 0, $x) );
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 3;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ close $fh;
+
+ open ($fh, '<', PREFIX.'/data/iso3166_2');
+ <$fh>; # pop first line off.
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = map( { $dbh->quote($_) } parse_line(",\\s*", 0, $x) );
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 3;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ close $fh;
+ $dbh->do(("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries))) if scalar(@entries);
+ @entries = ();
+ $dbh->do("ALTER TABLE `new_$table` ENABLE KEYS");
+####### END regions #######
+ say " Done.";
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $time1 = time();
+ print "Loading country data...";
+####### iso3166 Country Names #######
+ open ($fh, '<', PREFIX.'/data/iso3166');
+ $table = 'geocountry';
+ $columns = "(`code`, `country`)";
+
+ $dbh->do("ALTER TABLE `new_$table` DISABLE KEYS");
+
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = map( { $dbh->quote($_) } parse_line(",\\s*", 0, $x) );
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 2;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ $dbh->do(("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries))) if scalar(@entries);
+ @entries = ();
+ $dbh->do("ALTER TABLE `new_$table` ENABLE KEYS");
+ close $fh;
+####### END iso3166 Country Names #######
+ say " Done.";
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+
+ $dbh->do("UNLOCK TABLES");
+}
+
+sub convert($) {
+ my ($dbh) = @_;
+
+ my $time1 = time();
+ runSQL($dbh,
+ "DROP TABLE IF EXISTS `tmp_geoip`",
+ "RENAME TABLE `new_geoip` TO `tmp_geoip`",
+ "CREATE TABLE `new_geoip` (
+ `low` int unsigned NOT NULL,
+ `high` int unsigned NOT NULL,
+ `location` mediumint(8) unsigned NOT NULL,
+ `ip_poly` polygon not null,
+ PRIMARY KEY (`low`, `high`),
+ SPATIAL INDEX (`ip_poly`)
+ ) Engine=MyISAM",
+ "ALTER TABLE `new_geoip` DISABLE KEYS",
+ "INSERT INTO new_geoip (low,high,location,ip_poly)
+ SELECT low, high, location,
+ GEOMFROMWKB(POLYGON(LINESTRING( POINT(low, -1), POINT(high, -1),
+ POINT(high, 1), POINT(low, 1), POINT(low, -1)))) FROM tmp_geoip;",
+ "ALTER TABLE `new_geoip` ENABLE KEYS",
+ "DROP TABLE IF EXISTS `tmp_geoip`",
+ );
+ my $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+}
+
+sub cleanup($) {
+ my ($dbh) = @_;
+
+# print "\b\b\b\bdone.\nRemoving old table...\n";
+ $dbh->do("DROP TABLE IF EXISTS `oldcountry`");
+ say "Renaming new tables...";
+ $dbh->{RaiseError} = 0;
+ $dbh->{PrintError} = 0;
+ $dbh->do("OPTIMIZE TABLE `new_geoip`");
+ $dbh->do("ANALYZE TABLE `new_geoip`");
+ # Doing the renames cannot be done atomically
+ # as sometimes `country` doesn't exist yet.
+ $dbh->do("START TRANSACTION");
+ $dbh->do("RENAME TABLE `geoip` TO `old_geoip`");
+ $dbh->do("RENAME TABLE `new_geoip` TO `geoip`");
+
+ $dbh->do("RENAME TABLE `geolocation` TO `old_geolocation`");
+ $dbh->do("RENAME TABLE `new_geolocation` TO `geolocation`");
+
+ $dbh->do("RENAME TABLE `metrocode` TO `old_metrocode`");
+ $dbh->do("RENAME TABLE `new_metrocode` TO `metrocode`");
+
+ $dbh->do("RENAME TABLE `georegion` TO `old_georegion`");
+ $dbh->do("RENAME TABLE `new_georegion` TO `georegion`");
+
+ $dbh->do("RENAME TABLE `geocountry` TO `old_geocountry`");
+ $dbh->do("RENAME TABLE `new_geocountry` TO `geocountry`");
+
+ $dbh->do("DROP TABLE `old_geoip`");
+ $dbh->do("DROP TABLE `old_geolocation`");
+ $dbh->do("DROP TABLE `old_metrocode`");
+ $dbh->do("DROP TABLE `old_georegion`");
+ $dbh->do("DROP TABLE `old_geocountry`");
+ $dbh->do("COMMIT");
+ #unlink PREFIX.'/data/'.unpackname;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# This file is part of SurrealServices.
+#
+# SurrealServices is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# SurrealServices is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SurrealServices; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# SurrealChat.net does not provide the Country/Allocation data,
+# is in no way associated with maxmind.com,
+# nor are we providing a license to download/use it.
+# Be sure to direct availability/accuracy/licensing questions to maxmind.com
+
+use strict;
+#use warnings;
+use DBI;
+
+BEGIN {
+ use Cwd qw( abs_path getcwd );
+ use File::Basename;
+ my %constants = (
+ CWD => getcwd(),
+ PREFIX => abs_path(dirname(abs_path($0)).'/..'),
+ );
+ require constant; import constant(\%constants);
+}
+#chdir PREFIX;
+use lib PREFIX;
+
+use Date::Parse;
+use Text::ParseWords; # is a standard (in 5.8) module
+use Time::HiRes qw( time );
+
+use SrSv::Conf::sql;
+use SrSv::Conf2Consts qw( sql );
+use SrSv::Util qw( :say );
+use SrSv::Time qw( split_time );
+
+sub runSQL($@) {
+ my ($dbh, @strings) = @_;
+ foreach my $string (@strings) {
+ my $sql;
+ foreach my $x (split($/, $string)) { $sql .= $x unless $x =~ /^(#|--)/ or $x eq "\n"}
+# $dbh->do("START TRANSACTION");
+ my $printError = $dbh->{PrintError};
+ $dbh->{PrintError} = 0;
+ foreach my $line (split(/;/s, $sql)) {
+ next unless length($line);
+ #print "$line\n";
+ eval { $dbh->do($line); };
+ if($@) {
+ $line =~ s/\s{2,}/ /g;
+ $line =~ s/\n//g;
+ print "$line\n";
+ }
+
+ }
+ $dbh->{PrintError} = $printError;
+# $dbh->do("COMMIT");
+ }
+}
+
+BEGIN {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime();
+ $year += 1900;
+ $mon++; # gmtime returns months January=0
+ my $date = sprintf("%04d%02d01", $year, $mon);
+ require constant;
+ import constant {
+ #countrydb_url => 'http://www.maxmind.com/download/geoip/database/GeoIPCountryCSV.zip',
+ #FIXME: This needs a date generator!
+ countrydb_url => "http://www.maxmind.com/download/geoip/database/GeoLiteCity_CSV/GeoLiteCity_${date}.zip",
+ srcname => "GeoLiteCity_${date}.zip",
+ };
+}
+
+sub main() {
+ downloadData();
+ say "Connecting to database...";
+ my $dbh = dbConnect();
+ say "Creating new table...";
+ newTable($dbh);
+ say "Inserting data... ";
+ loadData($dbh);
+ print "Converting geoip table...";
+ convert($dbh);
+ cleanup($dbh);
+ $dbh->disconnect();
+ say "GeoIP update complete.";
+}
+
+main();
+exit 0;
+
+sub downloadData() {
+ # This MAY be implementable with an open of a pipe
+ # pipe the output of wget through gzip -d
+ # and then into the load-loop.
+ # It's a bit heavy to run directly from inside services however.
+ # I'd recommend it be run as a crontab script separate from services.
+
+ #return;
+ my ($stat, $date, $size);
+ my $srcPath = PREFIX.'/data/'.srcname;
+ say $srcPath;
+ use File::stat;
+ if($stat = stat($srcPath)) {
+ print "Checking for updated country data...\n";
+ my $header = qx "wget --spider -S @{[countrydb_url]} 2>&1";
+ ($date) = ($header =~ /Last-Modified: (.*)/);
+ ($size) = ($header =~ /Content-Length: (.*)/);
+ }
+
+ if($stat and $stat->size == $size and $stat->mtime >= str2time($date)) {
+ say "Country data is up to date.";
+ } else {
+# say $stat->size == $size;
+# say $stat->mtime >= str2time($date);
+ say "Downloading country data...";
+# return;
+
+ unlink $srcPath;
+ system('wget '.countrydb_url." -O $srcPath");
+ unless(-e $srcPath) {
+ sayERR "FATAL: Download failed.";
+ exit;
+ }
+ }
+
+ mkdir PREFIX.'/data/GeoIP/';
+ say "Decompressing...";
+ unlink(glob(PREFIX.'/data/GeoIP/Geo*.csv'));
+ system("unzip -j $srcPath -d ".PREFIX.'/data/GeoIP/');
+ unless(-f PREFIX.'/data/GeoIP/GeoLiteCity-Blocks.csv') {
+ sayERR "FATAL: Decompression failed.";
+ exit -1;
+ }
+}
+
+sub dbConnect() {
+ my $dbh;
+ eval {
+ $dbh = DBI->connect("DBI:mysql:".sql_conf_mysql_db, sql_conf_mysql_user, sql_conf_mysql_pass,
+ { AutoCommit => 1, RaiseError => 1 })
+ };
+
+ if($@) {
+ print STDERR "FATAL: Can't connect to database:\n$@\n";
+ print STDERR "You must edit config/sql.conf and create a corresponding\nMySQL user and database!\n\n";
+ exit -1;
+ }
+ return $dbh;
+}
+
+sub newTable($) {
+ my ($dbh) = @_;
+ $dbh->{RaiseError} = 1;
+ $dbh->{PrintError} = 1;
+
+ runSQL($dbh,
+ "CREATE TEMPORARY TABLE `tmp_geoip` (
+ `low` int unsigned NOT NULL,
+ `high` int unsigned NOT NULL,
+ `location` mediumint(8) NOT NULL,
+ PRIMARY KEY (`low`, `high`)
+ ) Engine=MyISAM",
+
+ "DROP TABLE IF EXISTS new_geolocation",
+ #"locId,country,region,city,postalCode,latitude,longitude,metroCode,areaCode";
+ "CREATE TABLE `new_geolocation` (
+ `id` mediumint(8) unsigned NOT NULL,
+ `country` char(2) NOT NULL default '-',
+ `region` char(2) NOT NULL default '-',
+ `city` varchar(255) NOT NULL default '-',
+ `postalcode` varchar(6) NOT NULL default '-',
+ `latitude` float NOT NULL default 0.0,
+ `longitude` float NOT NULL default 0.0,
+ `metrocode` int unsigned NOT NULL default 0,
+ `areacode` int unsigned NOT NULL default 0,
+ PRIMARY KEY (`id`),
+ KEY `countrykey` (`country`)
+ ) Engine=MyISAM;",
+
+ "DROP TABLE IF EXISTS `new_metrocode`",
+ "CREATE TABLE `new_metrocode` (
+ `id` smallint NOT NULL default 0,
+ `metro` varchar(128) NOT NULL default '',
+ PRIMARY KEY (`id`)
+ ) Engine=MyISAM;",
+
+ "DROP TABLE IF EXISTS `new_geocountry`",
+ #"locId,country,region,city,postalCode,latitude,longitude,metroCode,areaCode";
+ "CREATE TABLE `new_geocountry` (
+ `code` char(2) NOT NULL default '',
+ `country` varchar(255) default '',
+ PRIMARY KEY (`code`)
+ ) Engine=MyISAM;",
+
+ "DROP TABLE IF EXISTS `new_georegion`",
+ #"locId,country,region,city,postalCode,latitude,longitude,metroCode,areaCode";
+ "CREATE TABLE `new_georegion` (
+ `country` char(2) NOT NULL default '',
+ `region` char(2) NOT NULL default '',
+ `name` varchar(255) default '',
+ PRIMARY KEY (`country`, `region`)
+ ) Engine=MyISAM;",
+
+ );
+}
+
+sub timeDiff($$) {
+ my ($time1, $time2) = @_;
+ my ($weeks, $days, $hours, $minutes, $seconds) = split_time($time2 - $time1);
+ return sprintf("%02d:%02d.%02d", $minutes, int($seconds), 100*($seconds-int($seconds)));
+}
+
+sub loadData($) {
+ my ($dbh) = @_;
+ $| = 1;
+=cut
+ my $unpackPath = PREFIX.'/data/'.unpackname;
+ my ($lines) = qx{wc -l $unpackPath};
+ my $div = int($lines/100);
+=cut
+ my ($i, @entries);
+ my $fh;
+ my $table;
+
+ my $time1 = time();
+ print "Loading geoip data...";
+####### geoip #######
+ $table = 'geoip';
+ $dbh->do("LOAD DATA LOCAL INFILE
+ '@{[PREFIX]}/data/GeoIP/GeoLiteCity-Blocks.csv'
+ INTO TABLE tmp_${table}
+ FIELDS TERMINATED BY ',' ENCLOSED BY '\"' IGNORE 2 LINES");
+####### END geoip #######
+ my $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $time1 = time();
+ print "Loading location data...";
+####### locations #######
+ $table = 'geolocation';
+ $dbh->do("LOAD DATA LOCAL INFILE
+ '@{[PREFIX]}/data/GeoIP/GeoLiteCity-Location.csv'
+ INTO TABLE new_${table}
+ FIELDS TERMINATED BY ',' OPTIONALLY ENCLOSED BY '\"' IGNORE 2 LINES");
+####### END locations #######
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+
+ $time1 = time();
+ print "Loading metrocode data...";
+####### metrocodes #######
+ open ($fh, '<', PREFIX.'/data/GeoIP/metrocodes.txt');
+ $table = 'metrocode';
+ my $columns = "(`id`, `metro`)";
+
+ $dbh->do("ALTER TABLE `new_$table` DISABLE KEYS");
+
+ while(my $x = <$fh>) {
+ chomp $x;
+=cut
+ if($i == 0 or !($i % $div)) {
+ printf("\b\b\b\b%3d%", ($i/$lines)*100);
+ }
+=cut
+ my @args = map( { $dbh->quote($_) } split(' ', $x, 2) );
+ push @entries, '(' . join(',', @args) . ')' if scalar(@args) == 2;
+ if(scalar(@entries) >= 100) { #1000 only gives another 10% boost for 10x as much memory
+ $dbh->do("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries));
+ @entries = ();
+ }
+
+ $i++;
+ }
+ $dbh->do(("INSERT INTO `new_$table` $columns VALUES ".join(',', @entries))) if scalar(@entries);
+ @entries = ();
+ $dbh->do("ALTER TABLE `new_$table` ENABLE KEYS");
+ close $fh;
+####### END metrocodes #######
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $time1 = time();
+ print "Loading region data...";
+####### regions #######
+ $table = 'georegion';
+ $columns = "(`country`, `region`, `name`)";
+
+ $dbh->do("LOAD DATA LOCAL INFILE
+ '@{[PREFIX]}/data/fips10_4'
+ INTO TABLE new_${table}
+ FIELDS TERMINATED BY ',' OPTIONALLY ENCLOSED BY '\"' IGNORE 1 LINES");
+
+ $dbh->do("LOAD DATA LOCAL INFILE
+ '@{[PREFIX]}/data/iso3166_2'
+ INTO TABLE new_${table}
+ FIELDS TERMINATED BY ',' OPTIONALLY ENCLOSED BY '\"' IGNORE 1 LINES");
+
+####### END regions #######
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $time1 = time();
+ print "Loading country data...";
+####### iso3166 Country Names #######
+ $table = 'geocountry';
+ $dbh->do("LOAD DATA LOCAL INFILE
+ '@{[PREFIX]}/data/iso3166'
+ INTO TABLE new_${table}
+ FIELDS TERMINATED BY ',' OPTIONALLY ENCLOSED BY '\"' IGNORE 1 LINES");
+####### END iso3166 Country Names #######
+ $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+ $dbh->do("UNLOCK TABLES");
+}
+
+sub convert($) {
+ my ($dbh) = @_;
+
+ my $time1 = time();
+ runSQL($dbh,
+ "CREATE TABLE `new_geoip` (
+ `low` int unsigned NOT NULL,
+ `high` int unsigned NOT NULL,
+ `location` mediumint(8) NOT NULL,
+ `ip_poly` polygon NOT NULL,
+ PRIMARY KEY (`low`, `high`),
+ SPATIAL INDEX (`ip_poly`)
+ ) Engine=MyISAM",
+ "ALTER TABLE `new_geoip` DISABLE KEYS",
+ "INSERT INTO new_geoip (low,high,location,ip_poly)
+ SELECT low, high, location,
+ GEOMFROMWKB(POLYGON(LINESTRING( POINT(low, -1), POINT(high, -1),
+ POINT(high, 1), POINT(low, 1), POINT(low, -1)))) FROM tmp_geoip;",
+ "ALTER TABLE `new_geoip` ENABLE KEYS",
+ "DROP TABLE IF EXISTS `tmp_geoip`",
+ );
+ my $time2 = time();
+ print " Done. "; say timeDiff($time1, $time2);
+
+}
+
+sub cleanup($) {
+ my ($dbh) = @_;
+
+# print "\b\b\b\bdone.\nRemoving old table...\n";
+ $dbh->do("DROP TABLE IF EXISTS `oldcountry`");
+ say "Renaming new tables...";
+ $dbh->{RaiseError} = 0;
+ $dbh->{PrintError} = 0;
+ $dbh->do("OPTIMIZE TABLE `new_geoip`");
+ $dbh->do("ANALYZE TABLE `new_geoip`");
+ # Doing the renames cannot be done atomically
+ # as sometimes `country` doesn't exist yet.
+ $dbh->do("START TRANSACTION");
+ $dbh->do("RENAME TABLE `geoip` TO `old_geoip`");
+ $dbh->do("RENAME TABLE `new_geoip` TO `geoip`");
+
+ $dbh->do("RENAME TABLE `geolocation` TO `old_geolocation`");
+ $dbh->do("RENAME TABLE `new_geolocation` TO `geolocation`");
+
+ $dbh->do("RENAME TABLE `metrocode` TO `old_metrocode`");
+ $dbh->do("RENAME TABLE `new_metrocode` TO `metrocode`");
+
+ $dbh->do("RENAME TABLE `georegion` TO `old_georegion`");
+ $dbh->do("RENAME TABLE `new_georegion` TO `georegion`");
+
+ $dbh->do("RENAME TABLE `geocountry` TO `old_geocountry`");
+ $dbh->do("RENAME TABLE `new_geocountry` TO `geocountry`");
+
+ $dbh->do("DROP TABLE `old_geoip`");
+ $dbh->do("DROP TABLE `old_geolocation`");
+ $dbh->do("DROP TABLE `old_metrocode`");
+ $dbh->do("DROP TABLE `old_georegion`");
+ $dbh->do("DROP TABLE `old_geocountry`");
+ $dbh->do("COMMIT");
+ #unlink PREFIX.'/data/'.unpackname;
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+
+my (%cmd_hash, %tok_hash);
+my $debug = 0;
+
+#open MSGH, "include/msg.h";
+while (my $l = <STDIN>) {
+ chomp $l;
+ if ($l =~ /^#define(\s|\t)MSG_(\w+)(\s|\t)+\"(\S+)\".*/) {
+ $cmd_hash{$2}->{MSG} = $4;
+ print $l."\n" if $debug;
+ print "$2 $4"."\n" if $debug;
+ }
+ elsif ($l =~ /^#define(\s|\t)TOK_(\w+)(\s|\t)+\"(\S+)\".*/) {
+ $cmd_hash{$2}->{TOK} = $4;
+ print $l."\n" if $debug;
+ print "$2 $4"."\n" if $debug;
+ }
+}
+#close MSGH;
+
+
+foreach my $key (keys(%cmd_hash)) {
+ my $tok = $cmd_hash{$key}{TOK};
+ my $msg = $cmd_hash{$key}{MSG};
+# print $msg.' 'x(12-length($msg)). $tok."\n" if ($msg and $tok);
+ $tok_hash{$tok} = $msg if ($msg and $tok);
+}
+
+for(my $l = 1; $l <= 2; $l++) {
+ foreach my $key (sort keys %tok_hash) {
+ print $tok_hash{$key}.' 'x(12-length($tok_hash{$key})). $key."\n" if length($key) == $l;
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+
+use Event 'loop';
+use IO::Handle;
+use IO::Socket::INET;
+use Errno ':POSIX';
+
+sign_on_clients(200);
+
+our @chans;
+for(ord 'a' .. ord 'z') {
+ push @chans, '#' . chr($_) x 3;
+}
+
+our @clients;
+
+sub create_line_splitter($$) {
+ my ($sock, $cb) = @_;
+ my $part;
+
+ return sub {
+ my $event = shift;
+ my ($r, $in);
+ while($r = $sock->sysread($in, 4096) > 0) {
+ my @lines = split(/\r?\n/s, $in, -1);
+
+ $lines[0] = $part . $lines[0];
+ $part = pop @lines;
+
+ $cb->($_) foreach (@lines);
+ }
+
+ if($r <= 0 and not $!{EAGAIN}) {
+ $event->w->cancel;
+ $sock->close;
+ }
+ }
+}
+
+sub send_lines($@) {
+ my $sock = shift;
+ print "<< ", join("\n", @_), "\n";
+ $sock->syswrite(join("\r\n", @_) . "\r\n");
+}
+
+sub junk($) {
+ my $maxlen = shift;
+ my $len = int(rand($maxlen/2) + $maxlen/2);
+
+ my $out;
+ while(--$len > 0) {
+ $out .= chr(rand((ord 'z') - (ord 'a')) + ord 'a');
+ }
+
+ return $out;
+}
+
+sub irc_connect($) {
+ my $sock = IO::Socket::INET->new (
+ PeerAddr => $_[0],
+ Type => SOCK_STREAM,
+ Blocking => 0,
+ );
+
+ send_lines($sock,
+ "NICK " . junk(9),
+ "USER " . (junk(9) . ' ') x 3 . " :". junk(50),
+ );
+
+ push @clients, $sock;
+
+ my $process_line = sub {
+ my $line = shift;
+ print ">> ", $line, "\n";
+
+ if($line =~ /^PING :(.*)/) {
+ send_lines($sock, "PONG :$1");
+ }
+ elsif($line =~ /\S+ 422/) {
+ foreach (@chans) {
+ send_lines($sock, "JOIN " . $_);
+ }
+ }
+ };
+
+ Event->io (
+ fd => $sock,
+ cb => create_line_splitter($sock, $process_line),
+ );
+}
+
+sub sign_on_clients($) {
+ my $num = shift;
+ Event->timer (
+ interval => 1,
+ cb => sub {
+ my $i = $num;
+ return sub {
+ $_[0]->w->cancel if(--$i < 0);
+ irc_connect('localhost:6667');
+ }
+ }->(),
+ );
+}
+
+our $stdin = new IO::Handle;
+$stdin->fdopen(fileno(STDIN), "r");
+
+Event->io (
+ fd => $stdin,
+ cb => create_line_splitter($stdin, sub {
+ print eval $_[0], "\n";
+ print $@ if $@;
+ }),
+);
+
+loop();
projects / irc / SurrealServices / srsv.git / commitdiff
