From f4a351e02f7d4aa14f28c85bad5f1e7f19cb4392 Mon Sep 17 00:00:00 2001 From: jankratochvil <> Date: Sun, 20 Feb 2005 10:52:07 +0000 Subject: [PATCH] This commit was manufactured by cvs2svn to create tag 'bp_lace'. Sprout from master 2005-02-20 10:52:06 UTC short 'Main trunk update from the "lace" branch.' Delete: .cvsignore .vimrc COPYING MANIFEST Makefile.PL PerlMail/Contacts.pm PerlMail/Contacts/9000.pm PerlMail/Contacts/9210.pm PerlMail/Lib.pm README contacts-n9k2mutt perlmail-accept perlmail-sendmail perlmail-submit xinetd.perlmail --- .cvsignore | 5 - .vimrc | 1 - COPYING | 340 -------------------- MANIFEST | 11 - Makefile.PL | 71 ----- PerlMail/Contacts.pm | 44 --- PerlMail/Contacts/9000.pm | 81 ----- PerlMail/Contacts/9210.pm | 133 -------- PerlMail/Lib.pm | 119 ------- README | 66 ---- contacts-n9k2mutt | 92 ------ perlmail-accept | 792 ---------------------------------------------- perlmail-sendmail | 204 ------------ perlmail-submit | 261 --------------- xinetd.perlmail | 13 - 15 files changed, 2233 deletions(-) delete mode 100644 .cvsignore delete mode 100644 .vimrc delete mode 100644 COPYING delete mode 100644 MANIFEST delete mode 100644 Makefile.PL delete mode 100644 PerlMail/Contacts.pm delete mode 100644 PerlMail/Contacts/9000.pm delete mode 100644 PerlMail/Contacts/9210.pm delete mode 100644 PerlMail/Lib.pm delete mode 100644 README delete mode 100755 contacts-n9k2mutt delete mode 100755 perlmail-accept delete mode 100755 perlmail-sendmail delete mode 100755 perlmail-submit delete mode 100644 xinetd.perlmail diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index 0aeef71..0000000 --- a/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -MANIFEST.bak -Makefile -Makefile.old -blib -pm_to_blib diff --git a/.vimrc b/.vimrc deleted file mode 100644 index bdcca14..0000000 --- a/.vimrc +++ /dev/null @@ -1 +0,0 @@ -set ts=2 sw=2 diff --git a/COPYING b/COPYING deleted file mode 100644 index 5b6e7c6..0000000 --- a/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - 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. - - 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.) - -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. - - 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. - - 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 - - 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. - - - Copyright (C) - - 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. - - , 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. diff --git a/MANIFEST b/MANIFEST deleted file mode 100644 index f966380..0000000 --- a/MANIFEST +++ /dev/null @@ -1,11 +0,0 @@ -COPYING -MANIFEST -Makefile.PL -PerlMail/Config.pm -PerlMail/Contacts.pm -README -perlmail-accept -perlmail-sendmail -perlmail-submit -xinetd.perlmail -META.yml Module meta-data (added by MakeMaker) diff --git a/Makefile.PL b/Makefile.PL deleted file mode 100644 index 38005a8..0000000 --- a/Makefile.PL +++ /dev/null @@ -1,71 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2003 Jan Kratochvil -# -# 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 - - -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - -use ExtUtils::MakeMaker; - - -WriteMakefile( - "NAME"=>"PerlMail", - "AUTHOR"=>"Jan Kratochvil ", - "VERSION_FROM"=>"Makefile.PL", - "depend"=>{"Makefile"=>'$(VERSION_FROM)'}, - "PREREQ_PM"=>{ - "Authen::SASL"=>0, - "Carp"=>0, - "Cz::Cstocs"=>0, - "DBI"=>0, - "Encode::Guess"=>0, - "Exporter"=>0, - "ExtUtils::MakeMaker"=>0, - "Fcntl"=>0, - "File::Basename"=>0, - "File::Spec::Link"=>0, - "Getopt::Long"=>0, - "HTML::Entities"=>0, - "HTTP::Cookies"=>0, - "HTTP::Request"=>0, - "IO::Handle"=>0, - "IO::Socket::INET"=>0, - "IPC::Open3"=>0, - "LWP::UserAgent"=>0, - "Lingua::EN::Squeeze"=>0, - "MIME::Base64"=>0, - "MIME::Head"=>0, - "MIME::Words"=>0, - "Mail::Address"=>0, - "Mail::Alias"=>0, - "Mail::Audit"=>0, - "Mail::Mailer"=>0, - "Net::Cmd"=>0, - "Net::SMTP"=>0, - "POSIX"=>0, - "Sys::Syslog"=>0, - "Text::CSV::Simple"=>0, - "URI::Escape"=>0, - "User::Utmp"=>0, - "WWW::SMS"=>0, - }, - "EXE_FILES"=>["perlmail-accept","perlmail-submit","perlmail-sendmail","contacts-n9k2mutt"], - ); diff --git a/PerlMail/Contacts.pm b/PerlMail/Contacts.pm deleted file mode 100644 index 0767261..0000000 --- a/PerlMail/Contacts.pm +++ /dev/null @@ -1,44 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2004 Jan Kratochvil -# -# 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 - - -package PerlMail::Contacts; -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - - -sub new -{ -my($class)=@_; -my $self=bless { - "data"=>[], - },$class; - - return $self; -} - -# sub in -# my($self,$data)=@_; - -# sub out -# my($self,$data)=@_; - -1; diff --git a/PerlMail/Contacts/9000.pm b/PerlMail/Contacts/9000.pm deleted file mode 100644 index ebc7195..0000000 --- a/PerlMail/Contacts/9000.pm +++ /dev/null @@ -1,81 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2004 Jan Kratochvil -# -# 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 - - -package PerlMail::Contacts::9000; -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; -use vars qw(@ISA); -require PerlMail::Contacts; -@ISA=qw(PerlMail::Contacts); - - -sub _parse -{ -my($self,$data,@headers)=@_; - - my $re=join("(.*?)(\r\n)?",map("\Q[$_]\E\r\n",@headers)); - $re=qr/^$re/s; - my @r=(); - while (my @items=($data=~/$re/s)) { - my %h=(); - for my $i (0..$#headers) { - $h{$headers[$i]}=(!$items[2*$i+1] ? undef : $items[2*$i+0]) - } - push @r,\%h; - $data=substr($data,length $&); - } - die "Unrecognized data (parsing ".join("/",@headers)."): $data" if $data; - return @r; -} - -sub in -{ -my($self,$data)=@_; - - $self=$self->new() if !ref $self; - push @{$self->{"data"}},map({ - [ $self->_parse($_->{"RECORD"}."\r\n","FIELD","FIELD-NAME","FIELD-DATA","FIELD-END") ]; - } $self->_parse($data,"RECORD","RECORD-END")); - return (wantarray() ? @{$self->{"data"}} : $self->{"data"}); -} - -sub _join -{ -my($self,$href,@headers)=@_; - - my $trailer=pop @headers; - return join("",map(("[$_]\r\n".(!defined $href->{$_} ? "" : $href->{$_}."\r\n")),@headers))."[$trailer]\r\n"; -} - -sub out -{ -my($self,$data)=@_; - - $data=$self->{"data"} if !$data; - return join("",map({ - "[RECORD]\r\n".join("",map({ - $self->_join($_,"FIELD","FIELD-NAME","FIELD-DATA","FIELD-END"); - } @$_))."[RECORD-END]\r\n"; - } @$data)); -} - -1; diff --git a/PerlMail/Contacts/9210.pm b/PerlMail/Contacts/9210.pm deleted file mode 100644 index 9d7a880..0000000 --- a/PerlMail/Contacts/9210.pm +++ /dev/null @@ -1,133 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2004 Jan Kratochvil -# -# 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 - - -package PerlMail::Contacts::9210::Text::CSV::Simple; -use vars qw(@ISA); -require Text::CSV::Simple; -@ISA=qw(Text::CSV::Simple); -require Encode::Guess; -use bytes; - -sub _contents -{ -my($self)=@_; - - my $pathname=$self->{"_file"}; - my $F; - if (substr($pathname,0,1) eq "\x00") { - $F=substr($pathname,1); - } - else { - local *F; - open F,$pathname or die "open \"$pathname\": $!"; - $F=do { undef $/; ; }; - close F or die "close \"$pathname\": $!"; - } - my $encoding=Encode::Guess::guess_encoding($F); - ref $encoding or die "Cannot guess encoding of: $pathname"; - my $F_utf8=$encoding->decode($F); - $F_utf8=~tr/\r\n/\n\n/s; - return split /\n/,$F_utf8; -} - - -package PerlMail::Contacts::9210; -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; -use vars qw(@ISA); -require PerlMail::Contacts; -@ISA=qw(PerlMail::Contacts); - - -sub in -{ -my($self,$data)=@_; - - $self=$self->new() if !ref $self; - my @F=PerlMail::Contacts::9210::Text::CSV::Simple->new()->read_file("\x00".$data); - my @id=@{shift @F}; - $id[0] eq "CntMngCsv 3.0.0" or die "Unknown file format"; - shift @F; # drop unknown header numbers; - my @names=@{shift @F}; - $names[0] eq "ID" or die "field[0] not 'ID'"; - my %id; - for my $fields (@F) { - @names==@$fields or die "Fields line fields do not match the header names number"; - my $id=$fields->[0]; - my($omail_name,$omail_data); - my($name_last,$name_first); - my @mail; - for my $fieldi (1..$#names) { - my $string=$fields->[$fieldi]; - next if $string eq ""; - my $name=$names[$fieldi]; - my $first=!exists $id{$id}{$name}; - $id{$id}{$name}=$string if $first; - if ($name eq "Last name") { - die "Non-matching field" if $string ne $id{$id}{$name}; - $name_last=$string; - } - elsif ($name eq "First name") { - die "Non-matching field" if $string ne $id{$id}{$name}; - $name_first=$string; - } - elsif ($name eq "Company") { - die "Non-matching field" if $string ne $id{$id}{$name}; - push @{$id{$id}{""}},{ - "FIELD"=>"Company", - "FIELD-DATA"=>$string, - } if $first; - } - elsif ($name eq "Other Mail desc.") { - $omail_name=$string; - } - elsif ($name eq "Other Mail") { - $omail_data=$string; - } - elsif ($name eq "Mail") { - push @mail,undef()=>$string; - } - elsif ($name=~/^Mail [(](.*)[)]$/) { - push @mail,$1=>$string; - } - } - my $name=$name_last; - $name.=" ".$name_first if defined $name_first; - push @{$id{$id}{""}},{ - "FIELD"=>"Name", - "FIELD-DATA"=>$name, - } if defined $name; - push @mail,$omail_name=>$omail_data if defined $omail_data; - while (@mail) { - my $name=shift @mail; - my $data=shift @mail; - push @{$id{$id}{""}},{ - "FIELD"=>"Mail", - "FIELD-NAME"=>$name, - "FIELD-DATA"=>$data, - }; - } - } - return map(($id{$_}{""}||()),(sort { ($a<=>$b); } keys(%id))); -} - -1; diff --git a/PerlMail/Lib.pm b/PerlMail/Lib.pm deleted file mode 100644 index 200e4db..0000000 --- a/PerlMail/Lib.pm +++ /dev/null @@ -1,119 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2003 Jan Kratochvil -# -# 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 - - -package PerlMail::Lib; -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - -require Exporter; -use vars qw(@ISA @EXPORT); -@ISA=qw(Exporter); -@EXPORT=qw( - &parseone - &muttrc &muttrc_get); - -use PerlMail::Config; - -require Mail::Address; - - -# return: Mail::Address instance or undef() -sub parseone -{ -my($line)=@_; - - return undef() if !defined $line; - my @r=Mail::Address->parse($line); - warn "Got ".scalar(@r)." addresses while wanting just one; when parsing: $line" if 1!=@r; - return $r[0]; -} - -our %muttrc_pending=(); # not exported, just for local() -sub muttrc -{ -my($muttrc)=@_; - - $muttrc||="$HOME/.muttrc"; - $muttrc=~s/^\~/$HOME/; - do { warn "Looping muttrc, ignoring: $muttrc"; return (); } if $muttrc_pending{$muttrc}; - local $muttrc_pending{$muttrc}=1; - local *MUTTRC; - open MUTTRC,$muttrc or do { warn "open \"$muttrc\": $!"; return (); }; - local $/="\n"; - local $_; - my @r=(); - # far emulation mutt/init.c/mutt_parse_rc_line() - while () { - s/^[\s;]*//s; - s/[#;].*$//s; - s/\s*$//s; - next if !/^(\S+)\s*/s; - if ($1 eq "source") { - $_=$'; - do { warn "Wrong 'source' parameters at $muttrc:$.: $_"; next; } if !/^\S+$/; - push @r,muttrc($_); - next; - } - push @r,$_; - } - close MUTTRC or warn "close \"$muttrc\": $!"; - return wantarray() ? @r : join("",map("$_\n",@r)); -} - -my %mutteval_charmap=( # WARNING: Don't use "" or "0" here, see below for "|| warn"! - '\\'=>"\\", - 'r'=>"\r", - 'n'=>"\n", - 't'=>"\t", - 'f'=>"\f", - 'e'=>"\e", - ); -# mutt/init.c/mutt_extract_token() -sub mutteval -{ - local $_=$_[0]; - return $_ if !s/^"//; - do { warn "Missing trailing quote in: $_"; return $_; } if !s/"$//; - s/\\(.)/$mutteval_charmap{$1} || warn "Undefined '\\$1' sequence in: $_";/ges; - return $_; -} - -sub muttrc_get -{ -my(@headers)=@_; - - my @r=map({ (ref $_ ? $_ : qr/^\s*set\s+\Q$_\E\s*=\s*(.*?)\s*$/si); } @headers); - my %r=map(($_=>undef()),@r); - for (muttrc()) { - for my $ritem (@r) { - /$ritem/si or next; - $r{$ritem}=mutteval $1; - } - } - for my $var (grep { !defined($r{$_}) } @r) { - warn "Variable '$var' not found in muttrc"; - return undef(); - } - return wantarray() ? %r : $r{$r[0]}; -} - -1; diff --git a/README b/README deleted file mode 100644 index ea23ffe..0000000 --- a/README +++ /dev/null @@ -1,66 +0,0 @@ -$Id$ - - -Installation ------------- - -Edit: PerlMail/Config.pm -MySQL database password store to: /home/USERNAME/priv/mysql.USERNAME.pwd -Run: ./perlmail-submit --initdb - - -(if you are using xinetd(8) instead of inetd(8)) workstation: /etc/xinetd.d/perlmail -Copy "xinetd.perlmail" as "/etc/xinetd.d/perlmail". -substitute: USERNAME, PATH/TO -Use ntsysv(8) to enable the service "perlmail". - -(if you are using inetd(8) instead of xinetd(8)) workstation: /etc/inetd.conf -substitute: USERNAME, PATH/TO ----------------------------------- cut here ---------------------------------- -852 stream tcp nowait USERNAME /home/USERNAME/PATH/TO/PerlMail/perlmail-accept perlmail-accept --inetd ----------------------------------- cut here ---------------------------------- - - -(optional, recommended) workstation: /etc/services ----------------------------------- cut here ---------------------------------- -perlmail 852/tcp ----------------------------------- cut here ---------------------------------- - - -(optional if using sendmail wrapper) workstation: /etc/aliases -run after: newaliases -substitute: USERNAME ----------------------------------- cut here ---------------------------------- -sentout: /home/USERNAME/Mail/sentout ----------------------------------- cut here ---------------------------------- - - -(optional if using sendmail wrapper) workstation: Run -substitute: USERNAME, PATH/TO ----------------------------------- cut here ---------------------------------- - mv /usr/sbin/sendmail /usr/sbin/sendmail-orig - ln -s /home/USERNAME/PATH/TO/PerlMail/perlmail-sendmail /usr/sbin/sendmail ----------------------------------- cut here ---------------------------------- - - -server: crontab -e -substitute: PATH/TO ----------------------------------- cut here ---------------------------------- -*/10 * * * * exec $HOME/PATH/TO/PerlMail/perlmail-submit &>/dev/null --submit --clean 4d ----------------------------------- cut here ---------------------------------- - - -server: $HOME/.procmailrc -substitute: PATH/TO ----------------------------------- cut here ---------------------------------- -#:0 c: -#Mail/backup - -# PerlMail forward -:0 W -|./PATH/TO/PerlMail/perlmail-submit --store --forkoff --submit >/dev/null 2>>.perlmail-submit.log - -# PerlMail fallback -:0: -Mail/perlmail-submit-failed ----------------------------------- cut here ---------------------------------- diff --git a/contacts-n9k2mutt b/contacts-n9k2mutt deleted file mode 100755 index 6136f45..0000000 --- a/contacts-n9k2mutt +++ /dev/null @@ -1,92 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2003 Jan Kratochvil -# -# 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 - -# Name: Lastname Firstname "nick1" "nick2", dropped text -# Company: same as Name to indicate company record - - -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - -require Getopt::Long; -require Mail::Address; - - -Getopt::Long::Configure( - "no_ignorecase", - "bundling", - ); -my $opt_9000; -die if !Getopt::Long::GetOptions( - "9000"=>\$opt_9000, - ); - -my $type="9210"; -$type="9000" if $opt_9000; -my $class="PerlMail::Contacts::$type"; -eval "require $class;1;" or die "Cannot load loader $class: $!"; - -undef $/; -while (<>) { - my @data=map({ - my @record=@$_; - my %record; - map({ - my %item=%$_; - $record{$item{"FIELD"}}=$item{"FIELD-DATA"}; - ($item{"FIELD"} ne "Mail" || !$item{"FIELD-DATA"} ? () : ({ - "name"=>$record{"Name"}, - "mail"=>$item{"FIELD-DATA"}, - "attr"=>$item{"FIELD-NAME"}, - "iscompany"=>($record{"Name"} && $record{"Company"} && $record{"Name"} eq $record{"Company"}), - })); - } @record); - } $class->in($_)); - my @nicked=map({ - my $data=$_; - my($name,$mail,$attr,$iscompany)=map(($data->{$_}),qw(name mail attr iscompany)); - $name=~s/,.*$//s; - my @nicks=(); - my $name_force; - while ($name=~s/"([^"]*)"([!])?//s) { - push @nicks,$1; - $name_force=$1 if $2; - } - $name=~s/\s*$//s; - $name=~s/^(\w+)\s+(\w+)$/$2 $1/s if !$iscompany; - push @nicks,$name if !$name_force; - for (@nicks) { - $_.=".$attr" if $attr; - s/\s+/./gs; - } - map({ - "nick"=>$_, - "obj"=>Mail::Address->new(($name_force || $name),$mail), - },@nicks); - } @data); - my %dupe; - for (@nicked) { - my $nick=$_->{"nick"}; - my $dupe=$dupe{$nick}++; - $nick.=".$dupe" if $dupe; - print "alias $nick ".$_->{"obj"}->format()."\n"; - } - } diff --git a/perlmail-accept b/perlmail-accept deleted file mode 100755 index d9a944d..0000000 --- a/perlmail-accept +++ /dev/null @@ -1,792 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2003 Jan Kratochvil -# -# 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 - - -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - - -INIT { - require Sys::Syslog; - Sys::Syslog::openlog("perlmail","pid","mail"); - my @syslogging_stack; - sub syslogging_on_save - { - push @syslogging_stack,$SIG{"__WARN__"},$SIG{"__DIE__" }; - $SIG{"__WARN__"}=sub { Sys::Syslog::syslog("warning","WARN: %s",$_[0]); }; # disabled: print STDERR $_[0]; - $SIG{"__DIE__" }=sub { Sys::Syslog::syslog("crit" ,"DIE: %s" ,$_[0]); }; - } - syslogging_on_save(); - sub syslogging_restore - { - $SIG{"__DIE__" }=pop @syslogging_stack; - $SIG{"__WARN__"}=pop @syslogging_stack; - } - } - - -use File::Basename; -BEGIN { - use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname($0); - use PerlMail::Config; - use PerlMail::Lib; - } - -use Mail::Audit qw(MAPS); -require IO::Handle; -use Carp qw(cluck confess); -use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG); -require POSIX; # for ceil -use User::Utmp; -use Getopt::Long; -require Mail::Address; -require MIME::Words; -require Cz::Cstocs; -require HTML::Entities; -require MIME::Head; -require Lingua::EN::Squeeze; -require Mail::Mailer; -require HTTP::Cookies; -require HTTP::Request; -require LWP::UserAgent; -use URI::Escape 'uri_escape'; -require WWW::SMS; -require Authen::SASL; # Sanity check for &Net::SMTP::auth -use MIME::Base64; -use IPC::Open3; -use POSIX ":sys_wait_h"; - - -our($Message,@AuditStored,$DoBell); -my %alternates_host; # from @alternates_host -my %dnsbl_whitelist; # from @dnsbl_whitelist - -# from RedHat "procmail-3.22-5" -# /i should be only $procmailFROM_DAEMON but how it can hurt to /i all? -our $procmailTO_ =qr'^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To):(.*[^-a-zA-Z0-9_.])?'mio; -our $procmailTO =qr'^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To):(.*[^a-zA-Z])?'mio; -our $procmailFROM_DAEMON=qr'^(Mailing-List:|Precedence:.*(junk|bulk|list)|To: Multiple recipients of |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma?(st(e?r)?|n)|office)|(send)?Mail(er)?|daemon|m(mdf|ajordomo)|n?uucp|LIST(SERV|proc)|NETSERV|o(wner|ps)|r(e(quest|sponse)|oot)|b(ounce|bs\.smtp)|echo|mirror|s(erv(ices?|er)|mtp(error)?|ystem)|A(dmin(istrator)?|MMGR|utoanswer))(([^).!:a-z0-9][-_a-z0-9]*)?[%@> ][^<)]*(\(.*\).*)?)?$([^>]|$))'mio; -$procmailFROM_MAILER=qr'^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )[^>]*\b(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@> ][^<)]*(\(.*\).*)?)?$([^>]|$)'mio; -# perl-5.8.0 does not cope w/original FROM_MAILER on the third '?' character -# Thus we did '([^>]*[^(.%@a-z0-9])?' -> '[^>]*\b', I hope it is somehow similiar -# original FROM_MAILER =qr'^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@> ][^<)]*(\(.*\).*)?)?$([^>]|$)'mio; - -my $opt_mode; -my $opt_smstest; # 1 or $smscount -my $opt_idle; -my $opt_dry; -my $opt_single; - - -sub process; - -sub stdin -{ - syslogging_restore(); # This is more a debugging session - local $/="\n"; - my $message=""; - local $_; - while (<>) { - die "Invalid 'From ' line: $_" if $message eq "" && !/^From /; - if (!$opt_single && /^From / && $message) { - process $message; - $message=""; - } - $message.=$_; - } - process $message if $message; - exit 0; -} - -# FIXME: separate 'perlmail'-transfer together with perlmail-submit away -sub inetd -{ - die "Excessive arguments" if @ARGV; - - IO::Handle::autoflush STDOUT 1; - - while (1) { - local $/="\n"; - my $length=; - confess "Unexpected EOF" if !defined $length; - confess "Missing EOL" if $length!~s/\n$//s; - exit 0 if $length eq "BYE"; - confess "Unrecognized length: $length" if $length!~/^\d+$/; - my $message; - local $_; - $length==($_=read STDIN,$message,$length) or confess "Got $_ out of required $length bytes"; - $length==length $message or confess "False read return ".length($message)." instead of $length"; - { - # Do not: local *STDOUT; # FIXME: fd's inherited by spawned processes are not closed this way! - # local *STDERR; # FIXME: fd's inherited by spawned processes are not closed this way! - # as IPC::Open3 and IPC::Open2 will not redirect the output - # and send it to the original socket instead! - local $DoBell=0; - process $message; - if ($DoBell) { - bell() or warn "Unable to BELL"; - } - } - print STDOUT "1"; - } - die "NOTREACHED"; -} - -sub bell -{ - local *BELL; - open BELL,">/dev/tty11" or return 0; - print BELL "\x07"; - close BELL or return 0; - return 1; -} - -sub useridle -{ - return 0 if ! -e "$HOME/away"; - my %valid_users=map(($_=>1),@ValidUsers); - my($idlebest,$linebest); - for my $utmp (User::Utmp::getut(),{ "ut_line"=>"psaux" }) { - local $_; - next if defined($_=$utmp->{"ut_type"}) && $_!=User::Utmp::USER_PROCESS; - next if defined($_=$utmp->{"ut_user"}) && !$valid_users{$_}; - my $line="/dev/".$utmp->{"ut_line"}; - my $atime=(stat $line)[8]; - my $what="user \"".($utmp->{"ut_user"} || "")."\", line \"$line\""; - warn "Unable to stat $what" and next if !$atime; - my $idle=time()-$atime; - warn "atime in future for $what" and next if $idle<0; - next if $idle>$IdleMax; - next if defined $idlebest && $idlebest<=$idle; - $idlebest=$idle; - $linebest=$line; - } - return !wantarray() ? $idlebest : ($idlebest,$linebest); -} - -# return only the very (recursive) first part -sub body_first -{ - return $Audit if !$Audit->is_mime(); - my $first=$Audit; - local $_; - $first=$_ while $_=$first->parts(0); - return $first; -} - -sub mimehead -{ -my($part)=@_; - - return $Audit->is_mime() ? $part->head() - : MIME::Head->new([ split "\n",$Audit->head()->as_string() ]) - ; -} - -sub mimebody -{ -my($part)=@_; - - # be vary cautious here as most of $part methods will encode it! - return join "",@{$Audit->body()} if !$Audit->is_mime(); - my $bodyhandle=$part->bodyhandle(); - # If MIME is corrupted we don't get bodyhandle() for this part - # It may occur when "boundary" is specified by header but no such boundary is found in the body - return $bodyhandle->as_string() if $bodyhandle; - warn "MIME corrupted, adapting"; - return $part->body_as_string(); -} - -sub mime_type -{ -my($part)=@_; - - return $Audit->is_mime() ? $part->effective_type() : mimehead($part)->mime_type(); -} - -sub body_simple -{ - my $first=body_first(); - my $r=mimebody($first); - my $mime_type=mime_type($first); - if ($mime_type eq "text/html") { - # HTML::FormatText just does a useless text layouts - # PerlIO::via::StripHTML probably needs PerlIO input (?) - $r=~s/<[^>]*>//gs; - $r=HTML::Entities::decode($r); - # FIXME: detect charset from tag: "Content-type: text/html; charset=" - } - elsif ($mime_type eq "application/pgp-encrypted" - && (my $filename=mimehead($first)->mime_attr("Content-Disposition.filename")) - ) { - # first part contains just "Version: 1" as of GnuPG v1.0.4 (GNU/Linux) - $r="pgp($filename)"; - } - if ((my $charset=mimehead($first)->mime_attr("Content-Type.charset"))) { - my $cstocs=Cz::Cstocs->new($charset,"ascii"); - $r=&$cstocs($r) if $cstocs; # charset may be unknown - } - return $r; -} - -sub parts_linear -{ -my($part)=@_; - - return $Audit if !$part && !$Audit->is_mime(); - $part||=$Audit; - # don't use '!$part->parts()' as even 0-parts-multiparts are still multiparts - return $part if $part->bodyhandle(); - return map { (parts_linear($_)); } $part->parts(); -} - -sub smsbuild -{ -my($smsi,$smscount)=@_; - - return "$smsi/$smscount:" if $smscount>1; - return ""; -} - -sub smslens -{ -my($ignorenewmail,$smscount,%args)=@_; - - return map({ - my $l=160; - if (!$ignorenewmail) { # send by mail - $l-=length("Z emailu FIXME SMSmailError: "); - $l-=length(smsbuild($_,$smscount)); - } - else { # send by web - $l-=6; # 154 is the max length before split; why? - } - $l; - } (0..$smscount-1)); -} - -sub smssend_web -{ -my($squeezed,$smscount,@lens)=@_; - - $smscount=POSIX::ceil($smscount/5); - for my $smsi (0..$smscount-1) { - my $len=$lens[$smsi]; - $squeezed=~/^.{0,$len}/s; - my $frag=$&; - $squeezed=$'; - return 0 if 3!=@SMSwebRcpt; - local *F; - open F,"$HOME/priv/WWW-SMS-$SMSwebRcpt_username.pwd" or return 0; - my $pwd=; - chomp $pwd; - close F; - my $sms=WWW::SMS->new(@SMSwebRcpt,$frag,"username"=>$SMSwebRcpt_username,"passwd"=>$pwd); - for ($sms->gateways("sorted"=>"reliability")) { - last if $sms->send($_); - Sys::Syslog::syslog("warning","Web SMS send failed: %s",$WWW::SMS::Error); - my $void=$WWW::SMS::Error; # Prevent: Name "WWW::SMS::Error" used only once - } - } - return 1; -} - -sub smssend_mail -{ -my($squeezed,$smscount,@lens)=@_; - - return 0; -} - -sub smssend -{ -my($ignorenewmail,$smscount,%args)=@_; - - my $text=PerlMail::Config::audit_sms( - "subject"=>unmime($Audit->subject()), - "from"=>[ Mail::Address->parse(unmime($Audit->from())) ], - "body"=>substr(body_simple(),0,$MaxBodySMS*(1+0.25*$smscount)), - %args); - my $texthead=""; - ($texthead,$text)=@$text if ref $text; - do { print "$texthead\n$text\n"; return; } if $opt_smstest; - my @lens=smslens($ignorenewmail,$smscount,%args); - my $maxlen=0; - $maxlen+=$_ for (@lens); - my $squeezed; - for my $squeeze (@sms_squeezes) { - local $_; - Lingua::EN::Squeeze::SqueezeControl($_) if defined ($_=$squeeze->{"SqueezeControl"}); - $Lingua::EN::Squeeze::SQZ_OPTIMIZE_LEVEL or 1; # prevent: Name "$_" used only once: possible typo - $Lingua::EN::Squeeze::SQZ_OPTIMIZE_LEVEL=$_ if defined ($_=$squeeze->{"SQZ_OPTIMIZE_LEVEL"}); - $squeezed=Lingua::EN::Squeeze::SqueezeText($text); - chomp $squeezed; - last if $maxlen>=length($texthead.$squeezed); - } - $squeezed=substr $texthead.$squeezed,0,$maxlen; # strip if we passed thru last for() above - my $recalclen=0; - for ($smscount=0;$recalclen" if !defined($_) || /^\s*$/s; - s/^\s*//s; - s/\s*$//s; - return $_ if length($_)<128; - return substr($_,0,128)."..."; -} - -our $profile_eval_depth=0; -# ($name || @$name) -sub profile_eval -{ -my($name)=@_; - - die "Nesting profile: $name" if 0x10<=(local $profile_eval_depth=$profile_eval_depth+1); - return @$name if ref $name; - die "Profile not found: $name" if !exists $audit_profile{$name}; - my @this=@{$audit_profile{$name}}; - return (profile_eval($'),@this[1..$#this]) if $this[0] && $this[0]=~/^=/; - return @this; -} - -sub address_show -{ -my($text)=@_; - - return join(",",map({ $_->name() or $_->address(); } Mail::Address->parse($text))); -} - -sub unmime -{ -my($text)=@_; - - return join "",map({ - my $cstocs; - for (${$_}[1],"iso-8859-2") { - last if $_ && ($cstocs=Cz::Cstocs->new($_,"ascii")); - } - &$cstocs(${$_}[0]); - } MIME::Words::decode_mimewords($text)); -} - -# $folder: "$folder; comment" -# $profile as profile_eval($name) -sub store -{ -my($folder,$profile,%args)=@_; - - $profile=$store_profile if !$profile; - my %do=map({ (!/=/ ? ($_=>1) : ($`=>$')); } profile_eval($profile)); - Sys::Syslog::syslog("info","%s%s%s: %s: %s", - (!$opt_dry ? "" : "--dry: "), - (!$store_ignore ? "" : "IGNORED[$store_ignore]: "), - map({ cut($_); } $folder,address_show(unmime($Audit->from())),unmime($Audit->subject())), - ) - if $do{"syslog"} || $opt_dry; - $folder=~s/;.*$//s; - $folder="$Mail/".$' if $folder=~/^=/; - push @AuditStored,$folder if $do{"did"}; - return if $store_ignore || $opt_dry; - $DoBell++ if $do{"bell"}; - write_message($folder) or die; - smssend_tryall $store_ignorenewmail,$do{"sms"},%args if $do{"sms"}; -} - -our $did_last=0; - -# no &$funcref=>did smth in this block -# &$funcref,@funcargs -sub did -{ -my($funcref,@funcargs)=@_; - - return @AuditStored!=$did_last if !$funcref; - local $did_last=@AuditStored; - &$funcref(@funcargs); - return @AuditStored!=$did_last; -} - -# Never use Mail::Audit->store() as it will reformat MIME bodies and possibly corrupt OpenPGP! -sub write_message -{ -my($folder)=@_; - - return 1 if $opt_dry; # simulate OK - local *F; - open F,">>$folder" or do { warn "Append \"$folder\": $!"; return 0; }; - { - local $_; - ($_=Mail::Audit::audit_get_lock(\*F,$folder)) and do { warn "Lock \"$folder\": $!"; last; }; - seek F,0,IO::Handle::SEEK_END or do { warn "Seek-end \"$folder\": $!"; last; }; - # FIXME: Check for '^From ' to not to rely on our network peer - print F $Message or do { warn "Write to \"$folder\": $!"; last; }; - do { print F "\n"; warn "Missing trailing newline, fixed"; } if $Message!~/\n$/s; - close F or do { warn "Close \"$folder\""; last; }; - return 1; # OK - } - warn "MAIL DROPPED for folder: $folder"; - close F; - return 0; # failed -} - -sub process -{ -my($message)=@_; - - local $_=$_; - my $save_=$_; - $message=~s/(\n)(From )/$1>$2/sg; - local $Message=$message; - # Cannot call 'local' for our-imported variable: - my $Audit_save=$Audit; - $Audit=Mail::Audit->new( - "emergency"=>"$Mail/emergency", - "data"=>[map("$_\n",split("\n",$message))], - "log"=>"$HOME/.perlmail.log", - "loglevel"=>99, - ); - local @AuditStored=(); - do { smssend 0,$opt_smstest; return; } if $opt_smstest; - write_message("$Mail/input") or die; - PerlMail::Config::audit(); - warn 'Corrupted $_, repaired' if defined($save_)!=defined($_) || (defined($_) && $save_ ne $_); - # restore: - $Audit=$Audit_save; -} - -# utility functions: - -sub _spamchildcode -{ -my($err,$isspam)=@_; - - $err=$? if !defined $err; - return undef() if !WIFEXITED($?); - return undef() if WIFSIGNALED($?); - return undef() if WIFSTOPPED($?); - return $isspam||1 if WEXITSTATUS($?); # is-spam - return 0; # not-spam -} - -# return: true (error-message or "1") if is spam -sub spamassassin -{ -my($cmd)=@_; - - $cmd||="$HOME/bin/spamassassin --exit-code"; - # spamassassin has exit code 1 if IS spam, code 0 if NOT spam - local *CHILD; - local $SIG{"PIPE"}=sub { warn "spamassassin gave me SIGPIPE: broken pipe"; }; - # prevent Razor2's: Can't call method "log" on unblessed reference at Razor2/Client/Agent.pm line 212. - local $ENV{"HOME"}=$HOME; - # 2>/dev/null to prevent error messages to corrupt inetd() output of perlmail-accept(1) - open CHILD,"|$cmd --mbox >/dev/null 2>/dev/null" - or return 0; - print CHILD $Message; - close CHILD; - return _spamchildcode; -} - -# NOTE: returns undef() if !wantarray and the first header is unrecognized -# Returns always HOST:IP pair(s). -sub Received_for -{ - my @r=(); - for my $hdr ($Audit->head->get("Received")) { - my($for)=($hdr=~/\bfor\s+\?\b/); - return $for if !wantarray(); - push @r,$for if $for; - my($from,$fromaddr)=($hdr=~/\bfrom\s+(?:(\S+)\b.*?)??\[((?:\d{1,3}\.){3}\d{1,3})\]/); - $from=$fromaddr if !defined $from; - push @r,"$from:$fromaddr" if $from; - } - return @r; -} - -# Extended Mail::Audit::MAPS -# $domain,$full,[$timeout] -# Returns false if valid, code if spam detected. -sub dnsbl -{ -my($domain,$full,$timeout)=@_; - - $timeout||=30; # sec - $Mail::Audit::MAPS::host=$domain; - for my $host (Received_for()) { - next if $host!~/^([^:@]*):/; - my $ip=$'; - # $1 is DNS name, $ip is IP address - next if $alternates_host{$1}; # leave only foreign hosts - next if $dnsbl_whitelist{$ip}; - { - package My::Audit::Faked; - sub received { return @{$_[0]->{"received"}}; } - } - my $self_faked={ - "received"=>["[$ip]"], - }; - bless $self_faked,"My::Audit::Faked"; - my $code=Mail::Audit::rblcheck($self_faked,$timeout); - next if !$code; - # Some 0.0.0.0 etc. found for , see: &Mail::Audit::MAPS::_checkit - return $code if $code!='1 Invalid IP address '; - return if !$full; - } -} - -# Returns true if IS virus; the message will contain the virus name -sub clamscan -{ -my($cmd)=@_; - - $cmd||='clamscan --no-summary -'; - # clamscan has exit code 1 if IS virus , code 0 if NOT virus - # Do not use IPC::Open2 as it would try to use our STDERR which is not valid by: local *STDERR; - local(*WR,*RD,*ERR); - local $SIG{"PIPE"}=sub { warn "clamscan '$cmd' gave me SIGPIPE: broken pipe"; }; - my $pid=open3(\*WR,\*RD,\*ERR,$cmd.' 2>&1') - or do { cluck "IPC::Open3 $cmd: $!"; return 0; }; - print WR $Message; - close WR or do { cluck "close WR of $cmd: $!"; return 0; }; - my $status=do { local $/=undef(); ; }; - close RD or do { cluck "close RD of $cmd: $!"; return 0; }; - # Do not: $status.=do { local $/=undef(); ; }; - # close ERR or do { cluck "close ERR of $cmd: $!"; return 0; }; - # (FIXME) as it causes: Use of uninitialized value in - # waitpid fills $? for: &_spamchildcode - local $SIG{"ALRM"}=sub { warn "Timeout $clamscan_waitpid_timeout sec waiting for child $cmd"; }; - alarm $clamscan_waitpid_timeout; - # Do not: WNOHANG - # as it would not be enough for clamscan(1) even after all close-s above. - my $pidcheck=waitpid($pid,0); - alarm 0; - my $err=$?; - $pidcheck && $pidcheck==$pid - or do { cluck "waitpid for $cmd returned $pidcheck!=$pid"; return 0; }; - $status=~s/^stdin: //; - $status=~s/\n$//; - return $status if $status ne "OK" && $status; - return _spamchildcode $err,$status; -} - -sub muttrc_aliases -{ - my %r=(); - for (muttrc()) { - next if !(my $key=(/^alias\s+(\S+)\s+/)[0]); - for my $addrobj (Mail::Address->parse($')) { - my $addr=$addrobj->address(); - my $ref=\$r{"\L$addr"}; - $$ref=$key if !$$ref; # use always the first occurence to prefer nicks - } - } - return %r; -} - -# FIXME: host may get multiple recipients and thus not showing "for <...>" -# FIXME: muttrc_get("from") is too strict -sub store_muttrc_alternates -{ -my($prefix,$profile)=@_; - - my $alternates=muttrc_get("alternates") or return; - my $alternatesre=qr/$alternates/si; - my $From=muttrc_get("from") or return; - my $Fromre=qr/^\Q$From\E$/si; - my $Fromobj=parseone $From or return; - warn "'From' \"$From\" not matched by 'alternates': $alternatesre" - if $From!~/$alternates/si; - for my $for (reverse Received_for()) { - $for=~s/:.*$//; # strip IP address here - my $forobj=parseone $for; - if ($forobj && $forobj->host()) { - # it is 'for' our primary address - next if lc($forobj->host()) eq lc($Fromobj->host()); # or 'return'? shouldn't matter - } - next if !$alternates_host{lc $for} && $for!~/$alternatesre/si; - store "$prefix\L$for",($profile || []); - return; - } -} - -# $header: ref CODE -# $header: !ref => $Audit->get($header) -# $maybeaddress: qr/regex/i -# $maybeaddress: "string" -# $maybeaddress: "" # hack :-( -# $maybeaddress: "" -# $maybeaddress: "" -# $maybeaddress: "<@host>" -sub _headercore -{ -my($re,$justone,$header,$maybeaddress)=@_; - - if (ref $header) { - $header=join(",",&$header()); - } - else { - $header=$Audit->get($header); - } - return 0 if !$header; - return $header=~/$maybeaddress/i if "Regexp" eq ref $maybeaddress; - return $header=~/$re/i if !defined(my $want=($maybeaddress=~/^\<(.*)\>$/)[0]); - my @parsed=Mail::Address->parse($header); - warn "'mailto:' forbidden in pattern: $want" if $want=~/^\Qmailto:\E/; - return 0 if $justone && 1!=@parsed; - return grep { - if ($want=~/^Regexp:/) - { $_->address()=~/$'/i; } - elsif ($want=~/\@$/) - { $_->user() =~/^(?:\Qmailto:\E)?\Q$`\E/i; } - elsif ($want=~/^\@/) - { $_->host() =~/^\Q$'\E/i; } - else - { $_->address()=~/^(?:\Qmailto:\E)?\Q$want\E/i; } - } @parsed; -} - -sub headerhas -{ -my($header,$substr)=@_; - - return _headercore(qr/\Q$substr\E/i,0,$header,$substr); -} - -sub headeris -{ -my($header,$string)=@_; - - return _headercore(qr/\Q$string\E/i,1,$header,$string); -} - -# $header,%$map -sub header_remap -{ -my($header,$map)=@_; - - my $text=$Audit->get($header); - my $orig=$text; - while (my($from,$to)=each(%$map)) { - $text=~s/\b\Q$from\E\b/$to/gsi; - } - return if $text eq $orig; - $Audit->put_header("X-PerlMail-header_remap-$header",$orig); - $Audit->replace_header($header,$text); -} - -# LMTP engine: -use Net::Cmd qw(CMD_OK CMD_MORE); -{ - package My::Net::SMTP::LMTP; - require Net::SMTP; - our @ISA=qw(Net::SMTP); - use Net::SMTP; - use Net::Cmd qw(CMD_OK); - use Carp qw(confess cluck); - - # Do not: sub _HELO - # as it would not set {'net_smtp_esmtp'} - sub _EHLO { shift->command("LHLO", @_)->response() == CMD_OK } - - sub clucked - { - my($self,$func,@args)=@_; - - do { return $_ if defined $_; } for $self->$func(@args); - cluck $func; - return; - } -} - - -sub lmtp_deliver -{ -my($admin_user,$admin_pwd,$user_from,$user_to)=@_; - - my $lmtp=My::Net::SMTP::LMTP->clucked("new","localhost","Port"=>"lmtp", -# "Debug"=>1, - ) or return; - bless $lmtp,"My::Net::SMTP::LMTP"; -# Prevent: -# due to: -# $lmtp->auth(Authen::SASL->new( -# "mechanism"=>"PLAIN", -# "callback"=>{ -# "user"=>$admin_user, -# "pass"=>$admin_pwd, -# # Prevent: "authname"=>$admin_user -# # as it causes: DIE: Unknown callback: 'authname'. (user|auth|language|pass) -# })); - # FIXME: Authentication hack: - $lmtp->command("AUTH PLAIN")->response()==CMD_MORE - or do { cluck "auth announce"; return; }; - $lmtp->clucked("command",encode_base64($user_from."\x00".$admin_user."\x00".$admin_pwd)) or return; - $lmtp->clucked("mail",$user_from) or return; - $lmtp->clucked("to",$user_to) or return; - $lmtp->clucked("data"); # Do not: or return; - # Prevent: 554 5.6.0 Message contains invalid header - (my $data=$Message)=~s/\AFrom .*\r?\n//; - $lmtp->clucked("datasend",$data) or return; - $lmtp->clucked("dataend") or return; - $lmtp->clucked("quit") or return; -} - - -# MAIN - -$Getopt::Long::ignorecase=0; -die "GetOptions error" if !Getopt::Long::GetOptions( - "inetd" ,sub { $opt_mode=\&inetd; }, - "stdin" ,sub { $opt_mode=\&stdin; }, - "single!" ,\$opt_single, - "dry" ,\$opt_dry, - "smstest:s",sub { $opt_mode=\&stdin; $opt_smstest=($_[1] || 1); }, - "idle!" ,\$opt_idle, - "idletest" ,sub { syslogging_restore(); print((defined($_=useridle()) ? $_ : "")."\n"); exit 0; }, - "muttrc" ,sub { syslogging_restore(); print scalar muttrc(); exit 0; }, - ); -# "Excessive arguments" checked in &inetd -die "Missing mode" if !$opt_mode; - -%alternates_host=map((lc($_)=>1),@alternates_host); -%dnsbl_whitelist=map(( $_ =>1),@dnsbl_whitelist); - -&$opt_mode(); -die "NOTREACHED"; diff --git a/perlmail-sendmail b/perlmail-sendmail deleted file mode 100755 index 2177e2c..0000000 --- a/perlmail-sendmail +++ /dev/null @@ -1,204 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2003 Jan Kratochvil -# -# 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 - - -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - -use File::Basename; -use File::Spec::Link; -BEGIN { - eval 'use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname(File::Spec::Link->resolve($0));'; - } -use PerlMail::Config; -use PerlMail::Lib; - -require Getopt::Long; -use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG); -require MIME::Head; # inherits Mail::Header -require Mail::Address; - - -sub sendmail_show { return "\"$sendmail_orig\" ".join(",",map("\"$_\"",@ARGV)); } - -sub sendmail_orig_exec -{ - exec {$sendmail_orig} $0,@ARGV or die "exec(".sendmail_show()."): $!"; - die "NOTREACHED"; -} - -Getopt::Long::Configure( - "no_ignorecase", - "no_getopt_compat", - "bundling", - # FIXME: workaround: 'unknown options' are considered the same as 'arguments' - # None of ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) can help us. - # No preprocessing possible as it is hard to find option arguments. - "permute", - "pass_through", - ); - -my $opt_b; -my $opt_Q; -my $opt_q; -my $opt_t; -our $opt_f; # not exported, just for local() -my $opt_perlmail_dry_run; -my @ARGV_save=@ARGV; # for non-bm mode -die if !Getopt::Long::GetOptions( - "b=s" ,\$opt_b, - "Q:s" ,\$opt_Q, - "q:s" ,\$opt_q, - "t" ,\$opt_t, - "f=s" ,\$opt_f, - "F=s" ,\$opt_F, - "perlmail-dry-run+",\$opt_perlmail_dry_run, - ); -if (0 - # RedHat sendmail-8.12.5-7/sendmail/main.c/\QDo a quick prescan of the argument list.\E - || grep({ File::Basename::basename($0) eq $_; } "newaliases","mailq","smtpd","hoststat","purgestat") - # -bm: Deliver mail in the usual way (default). - || (defined($opt_b) && $opt_b ne "m") - || defined $opt_q # MD_QUEUERUN - || defined $opt_Q # MD_QUEUERUN - ) { - @ARGV=@ARGV_save; - sendmail_orig_exec(); - die "NOTREACHED"; - } - -# RedHat sendmail-8.9.3-20/src/main.c/main()/\Qif (FullName != NULL)\E -# for $opt_F is implemented by Mail::Address in our &FromAddress - -my $head=MIME::Head->new(\*STDIN); -# options leave in @ARGV, addresses to @addr: -my @args=@ARGV; # temporary -@ARGV=(); # options -my @addr=(); # addresses -push @{(/^-./ ? \@ARGV : \@addr)},$_ for (@args); -if ($opt_t) { - for my $addrobj (map({ Mail::Address->parse($_); } map({ ($head->get($_)); } @h_rcpt))) { - if (!$addrobj->address()) { - # bogus, shouldn't happen - warn "->address() not found in \"".$addrobj->format()."\""; - next; - } - push @addr,$addrobj; - } - } - -sub matches -{ - return -} - -my $from_headername; -{ - my $muttrc_From=parseone(scalar muttrc_get("from")); # may get undef()!; parseone() may be redundant - $muttrc_From=$muttrc_From->address() if $muttrc_From; - $opt_f=undef() if defined($opt_f) && $muttrc_From && lc($opt_f) eq lc($muttrc_From); - for (@h_from) { - $from_headername=$_; # leave last item in $from_headername - next if !(my @from_val=$head->get($from_headername)); - @from_val=map({ ($_->address()); } map({ (Mail::Address->parse($_)); } @from_val)); - $from_headername=undef() if !(1==@from_val && $muttrc_From && lc($from_val[0]) eq lc($muttrc_From)); - last; - } # fallthru with $from_headername remaining set if last headername did not exist - # now $from_headername contains the header name to be replaced w/substituted value - } - -# to be utilized later by &FromAddress -$is_pgp=(1 - && do { local $_=$head->mime_attr("Content-Type"); $_ && ~m#^multipart/(?:signed|encrypted)$#; } - && do { local $_=$head->mime_attr("Content-Type.protocol"); $_ && ~m#^application/pgp\b#; } - ); - -my $exitcode=0; -# !defined($rcpt) if we have no recipients -# make the list unique to prevent dupes being normally filtered by sendmail(8) -# one '{' is block-wrapper, another '{' is hash-indirection! -# hash keys are just strings, never refs! -# unify the list as Mail::Address instances -my @rcpts=(!@addr ? (undef()) : values(%{{ map({ - my $obj=$_; - $obj=parseone $obj if !ref $obj; - (!defined $obj ? () : (lc($obj->address())=>$obj)); - } @addr) }})); - -my $stdin_body=(@rcpts<=1 ? undef() : do { # store input data only if it will be used multiple times - local $/=undef(); - ; - }); -for my $rcpt (@rcpts) { - local @ARGV=@ARGV; - local $opt_f=$opt_f; - - if (defined $rcpt) { # !defined($rcpt) if we have no recipients - local $_; - $opt_f=FromAddress($rcpt,1)->address() if !defined $opt_f; - if ($from_headername) { - if (my $fromaddr=FromAddress($rcpt,0)->format()) { - $head->replace($from_headername,$fromaddr); - } - } - } - - 1; # drop '-bm' if present as it is default anyway - 1; # drop '-t' if present as we are looping now for it - push @ARGV,"-f",$opt_f if defined $opt_f; - # we don't handle "Full-Name" header thus pass "-F" - # "From/Resent-From" should be handled by our &FromAddress - push @ARGV,"-F",$opt_F if defined $opt_F; - push @ARGV,$rcpt->address() if defined $rcpt; - push @ARGV,@addr_addon; - - local $SIG{"PIPE"}=sub { die "Got SIGPIPE from ".sendmail_show(); }; - local *SENDMAIL; - if ($opt_perlmail_dry_run) { - print sendmail_show()."\n"; - *SENDMAIL=\*STDOUT; - } - else { - defined (my $pid=open SENDMAIL,"|-") or die "Cannot fork to spawn ".sendmail_show().": $!"; - sendmail_orig_exec() if !$pid; # child - } - $head->print(\*SENDMAIL); - print SENDMAIL "\n"; # MIME::Head->print() eats the empty line but it doesn't print it - if (defined($stdin_body)) { - print SENDMAIL $stdin_body; - } - else { - local $_; - while () { - print SENDMAIL $_; - } - } - - next if $opt_perlmail_dry_run; # don't close our STDOUT as it is aliased to *SENDMAIL - close SENDMAIL or warn "close(".sendmail_show()."): $?=".join(",", - (!WIFEXITED($?) ? () : ("EXITSTATUS(".WEXITSTATUS($?).")")), - (!WIFSIGNALED($?) ? () : ("TERMSIG(" .WTERMSIG($?) .")")), - (!WIFSTOPPED($?) ? () : ("STOPSIG(" .WSTOPSIG($?) .")")), - ); - my $gotcode=(!WIFEXITED($?) ? 99 : WEXITSTATUS($?)); - $exitcode=$gotcode if $gotcode>$exitcode; - } -exit $exitcode; diff --git a/perlmail-submit b/perlmail-submit deleted file mode 100755 index cc76cca..0000000 --- a/perlmail-submit +++ /dev/null @@ -1,261 +0,0 @@ -#! /usr/bin/perl -# -# $Id$ -# Copyright (C) 2002-2003 Jan Kratochvil -# -# 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 - - -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -use strict; -use warnings; - -use File::Basename; -BEGIN { - use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname($0); - use PerlMail::Config; - } - -use Getopt::Long; -use DBI; -use Carp qw(cluck confess); -require IO::Socket::INET; -use IO::Handle; -use POSIX qw(mktime); -use Fcntl qw(:flock); - - -my $DBI_CACHE=0; # Cache DBI requests - may cause: MySQL server has gone away - - -open DBI_PWD,$DBI_pwd or die "open \"$DBI_pwd\": $!"; -$DBI_pwd=; -close DBI_PWD or warn "close DBI_pwd: $!"; -chomp $DBI_pwd; - -my $DBI; -sub DBI -{ - return $DBI if $DBI_CACHE && $DBI; - $DBI=DBI->connect("DBI:mysql:database=$DBI_database;host=","$DBI_user",$DBI_pwd,{ - "PrintError"=>0, # handled by "RaiseError" below - "RaiseError"=>1, - "ShowErrorStatement"=>1, - "AutoCommit"=>1, - }) or confess "Failed DBI->connect(): $!"; - return $DBI; -} - -# $name,@$cols -sub create_table -{ -my($name,$cols)=@_; - - eval { DBI()->do("drop table $name"); }; - DBI()->do("create table $name (".join(",",@$cols).")"); -} - -sub initdb -{ - create_table($DB_table,[ - "id int not null auto_increment primary key", - "time timestamp not null", # assume ." default now()" - "message longtext not null", - "retries int null default 0", # null=>done, 0=not yet tried to submit - ], - ); - DBI()->do("alter table $DB_table add index (retries,id)"); - print "done.\n"; - exit 0; -} - -sub store -{ - my $message; - { - local $/; - $message=; - } - close STDIN or cluck "close STDIN: $!"; - my %row=( - "message"=>$message, - # assume "retries"=>0, - ); - my $prep=DBI()->prepare("insert into $DB_table (".join(",",keys(%row)).")" - ." values (".join(",",map("?",keys(%row))).")"); - $prep->execute(values(%row)); - print $prep->{"mysql_insertid"}."\n"; -} - -sub forkoff -{ - my $pid=fork(); - confess if !defined $pid; - $DBI=undef(); # Prevent: Server has gone away - exit 0 if $pid; # parent - # child -} - -my $submitonce_run=0; -sub submitonce -{ - $submitonce_run++; - local *LOCK; - open LOCK,">>$Lock_pathname" or die "open-append \"$Lock_pathname\": $!"; - if (!flock LOCK,LOCK_EX|LOCK_NB) { - # NEVER unlink here, we are not the lock owning process! - print "LOCKED\n"; - exit 0; - } - my $sth=DBI()->prepare("select id,message from $DB_table where retries is not null" - # process only non-problematic mails during rerun - .($submitonce_run==1 ? "" : " and retries=0") - ." order by retries asc,id asc"); - $sth->execute(); - my $progresschar=""; - autoflush STDOUT 1; - my $sock; - while (my $row=$sth->fetchrow_hashref()) { - DBI()->do("update $DB_table set retries=retries+1 where id=".$row->{"id"}); - if (!$sock) { - $sock=IO::Socket::INET->new( - "PeerAddr"=>$PeerAddr, - "Proto" =>"tcp", - ) or confess "IO::Socket::INET->new(\"$PeerAddr\"): $!"; - $sock->connected() or confess "socket not connected"; - } - $sock->printflush(length($row->{"message"})."\n".$row->{"message"}); - alarm $Socket_timeout and $sock->timeout($Socket_timeout) if $Socket_timeout; - my $got; - my $gotlen=$sock->sysread($got,1); - confess $row->{"id"}.": sysread(1)=".(!defined $gotlen ? "undef" : $gotlen).": $!" - if !defined($gotlen) || $gotlen!=1; - alarm 0; - if ($got ne "1") { - # Prevent mailing errors from cron invoking us etc. - #print STDERR "FAIL:".$row->{"id"}."\n"; - undef $sock; - } - else { - DBI()->do("update $DB_table set retries=null where id=".$row->{"id"}); - } - print $progresschar.$row->{"id"}.($got eq "1" ? "" : "=FAIL"); - $progresschar=","; - } - if ($sock) { - $sock->shutdown(0); # stopped reading - $sock->printflush("BYE\n"); - $sock->shutdown(2); # stopped using - undef $sock; - } - print "\n" if $progresschar; - unlink $Lock_pathname; - close LOCK; - return $progresschar; -} - -sub submit -{ - 1 while submitonce(); -} - -sub print_messages -{ -my($cond)=@_; - - my $sth=DBI()->prepare("select message from $DB_table $cond order by id"); - $sth->execute(); - while (my $row=$sth->fetchrow_hashref()) { - print $row->{"message"},"\n"; - } -} - -sub pending -{ - print_messages("where retries is not null"); -} - -sub dump -{ - print_messages(""); -} - -sub clean -{ -my($keyword,$interval)=@_; - - # FIXME: SQL "now()" is raced against the block above - my $sth=DBI()->prepare("select id,time,retries from $DB_table where time>now()"); - $sth->execute(); - while (my $row=$sth->fetchrow_hashref()) { - warn "Message time in future: ".join(",",map( - "$_=".(!defined $row->{$_} ? "NULL" : $row->{$_}) - ,keys(%$row))); - } - - return if $interval eq ""; - local $_=$interval; - my $print=s/^print://; - s/(\d+)y/($1*12)."m"/ge; - s/(\d+)m/($1*30)."d"/ge; - s/(\d+)d/($1*24)."h"/ge; - s/(\d+)h/($1*60)."M"/ge; - s/(\d+)M/($1*60)."s"/ge; - my $sec=0; - $sec+=$1 while s/(\d+)s//g; - die "Interval parse error; left \"$_\", parsed: $interval" if $_ ne ""; - $sth=DBI()->prepare(($print ? "select id" : "delete") - ." from $DB_table where retries is null and timeexecute(); - if (!$print) { - print $sth->rows()."\n"; - } - else { - while (my $row=$sth->fetchrow_hashref()) { - print $row->{"id"},"\n"; - } - } -} - -my $optwrap_err; -sub optwrap -{ -my($func,@args)=@_; - - # Prevent successful return due to --forkoff in the case of failed --store when using: - # perlmail-submit --store --forkoff --submit - if (!eval { &{$func}(@args); 1; }) { - $optwrap_err||=$@||$!; - die "!FINISH"; - die "NOTREACHED"; - } -} - -$Getopt::Long::ignorecase=0; -# &GetOptions will return success due to: die "!FINISH" -# but our error detection is done by $optwrap_err. -GetOptions( - "initdb" ,sub { optwrap \&initdb,@_; }, - "store" ,sub { optwrap \&store,@_; }, - "forkoff",sub { optwrap \&forkoff,@_; }, - "submit" ,sub { optwrap \&submit,@_; }, - "pending",sub { optwrap \&pending,@_; }, - "dump" ,sub { optwrap \&dump,@_; }, - "clean:s",sub { optwrap \&clean,@_; }, - "V|version",sub { print "perlmail-submit: $VERSION\n"; exit 0; }, - ); -die $optwrap_err if defined $optwrap_err; -exit 0; diff --git a/xinetd.perlmail b/xinetd.perlmail deleted file mode 100644 index d7db4a6..0000000 --- a/xinetd.perlmail +++ /dev/null @@ -1,13 +0,0 @@ -# default: off -# description: http://www.jankratochvil.net/project/PerlMail/ -service perlmail -{ - disable = no - socket_type = stream - port = 852 - wait = no - user = lace - server = /home/USERNAME/PATH/TO/PerlMail/perlmail-accept - server_args = --inetd - log_on_failure += USERID -} -- 1.8.3.1