Common code moved to PerlMail::Lib.

[PerlMail.git] / PerlMail / Lib.pm

diff --git a/PerlMail/Lib.pm b/PerlMail/Lib.pm
new file mode 100644 (file)
index 0000000..ccd7671
--- /dev/null
+++ b/PerlMail/Lib.pm
@@ -0,0 +1,119 @@
+#! /usr/bin/perl
+# 
+#      $Id$
+# Copyright (C) 2002-2003 Jan Kratochvil <short@ucw.cz>
+# 
+# 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;