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
+++ /dev/null
-MANIFEST.bak
-Makefile
-Makefile.old
-blib
-pm_to_blib
+++ /dev/null
-set ts=2 sw=2
+++ /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
-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)
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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 <project-PerlMail\@jankratochvil.net>",
- "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"],
- );
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2004 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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;
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2004 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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;
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2004 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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 $/; <F>; };
- 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;
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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 (<MUTTRC>) {
- 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;
+++ /dev/null
-$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 ----------------------------------
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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";
- }
- }
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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=<STDIN>;
- 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"} || "<local>")."\", 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 <meta> 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=<F>;
- 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<length $squeezed;$smscount++) {
- $recalclen+=$lens[$smscount];
- }
- my $func=($ignorenewmail ? \&smssend_web : \&smssend_mail);
- &$func($squeezed,$smscount,@lens);
-}
-
-sub smssend_tryall
-{
-my($ignorenewmail,@args)=@_;
-
- return if !$opt_smstest && !$opt_idle && defined useridle();
- local $_;
- return $_ if $_=smssend(1,@args); # web
- return $_ if !$ignorenewmail && ($_=smssend(0,@args)); # mail
- warn "Unable to SMSsend the mail";
- return 0;
-}
-
-sub cut
-{
- local $_=$_[0];
- return "<???>" 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+\<?(\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 <linux-kernel@>, 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(); <RD>; };
- close RD or do { cluck "close RD of $cmd: $!"; return 0; };
- # Do not: $status.=do { local $/=undef(); <ERR>; };
- # close ERR or do { cluck "close ERR of $cmd: $!"; return 0; };
- # (FIXME) as it causes: Use of uninitialized value in <HANDLE>
- # 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: "<Regexp:regex>" # hack :-(
-# $maybeaddress: "<user@host>"
-# $maybeaddress: "<user@>"
-# $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()) ? $_ : "<undef>")."\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";
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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();
- <STDIN>;
- });
-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 (<STDIN>) {
- 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;
+++ /dev/null
-#! /usr/bin/perl
-#
-# $Id$
-# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
-#
-# 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=<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=<STDIN>;
- }
- 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 time<from_unixtime(unix_timestamp()-$sec)");
- $sth->execute();
- 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;
+++ /dev/null
-# 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
-}
git://git.jankratochvil.net / PerlMail.git / commitdiff