Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 254 lines (207 sloc) 7.034 kB
6df92cd @abh half baked version of the new object mail engine
abh authored
1 package Qpsmtpd;
2 use strict;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
3 use vars qw($VERSION $LogLevel);
6df92cd @abh half baked version of the new object mail engine
abh authored
4
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored
5 use Sys::Hostname;
6 use Qpsmtpd::Constants;
6df92cd @abh half baked version of the new object mail engine
abh authored
7
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
8 $VERSION = "0.28-dev";
9 sub TRACE_LEVEL { $LogLevel }
10
11 sub version { $VERSION };
6df92cd @abh half baked version of the new object mail engine
abh authored
12
9d5610a @abh 0.20-dev
abh authored
13 $Qpsmtpd::_hooks = {};
14
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
15 sub init_logger {
16 my $self = shift;
17 # Get the loglevel - we localise loglevel to zero while we do this
18 my $loglevel = do {
19 local $LogLevel = 0;
20 $self->config("loglevel");
21 };
22 if (defined($loglevel) and $loglevel =~ /^\d+$/) {
23 $LogLevel = $loglevel;
24 }
25 else {
26 $LogLevel = LOGWARN; # Default if no loglevel file found.
27 }
28 return $LogLevel;
29 }
30
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored
31 sub log {
32 my ($self, $trace, @log) = @_;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
33 my $level = TRACE_LEVEL();
34 $level = $self->init_logger unless defined $level;
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored
35 warn join(" ", $$, @log), "\n"
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
36 if $trace <= $level;
6df92cd @abh half baked version of the new object mail engine
abh authored
37 }
38
39
40 #
41 # method to get the configuration. It just calls get_qmail_config by
42 # default, but it could be overwritten to look configuration up in a
43 # database or whatever.
44 #
45 sub config {
c10b6fb @abh Support morercpthosts.cdb
abh authored
46 my ($self, $c, $type) = @_;
6df92cd @abh half baked version of the new object mail engine
abh authored
47
173a2d2 @abh better error messages when a plugin fails
abh authored
48 #warn "SELF->config($c) ", ref $self;
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored
49
6df92cd @abh half baked version of the new object mail engine
abh authored
50 my %defaults = (
51 me => hostname,
52 timeout => 1200,
53 );
54
9d5610a @abh 0.20-dev
abh authored
55 my ($rc, @config) = $self->run_hooks("config", $c);
56 @config = () unless $rc == OK;
57
3e5de3a @abh separate queue method called from data.
abh authored
58 if (wantarray) {
c10b6fb @abh Support morercpthosts.cdb
abh authored
59 @config = $self->get_qmail_config($c, $type) unless @config;
bae4a84 Fixed defaults bug (freeside)
Matt Sergeant authored
60 @config = $defaults{$c} if (!@config and $defaults{$c});
3e5de3a @abh separate queue method called from data.
abh authored
61 return @config;
62 }
63 else {
c10b6fb @abh Support morercpthosts.cdb
abh authored
64 return ($config[0] || $self->get_qmail_config($c, $type) || $defaults{$c});
3e5de3a @abh separate queue method called from data.
abh authored
65 }
6df92cd @abh half baked version of the new object mail engine
abh authored
66 }
67
2fe35f1 @abh yay, plugin support works! :-D
abh authored
68
6df92cd @abh half baked version of the new object mail engine
abh authored
69 sub get_qmail_config {
c10b6fb @abh Support morercpthosts.cdb
abh authored
70 my ($self, $config, $type) = @_;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
71 $self->log(LOGDEBUG, "trying to get config for $config");
6df92cd @abh half baked version of the new object mail engine
abh authored
72 if ($self->{_config_cache}->{$config}) {
73 return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0];
74 }
e006f74 @abh Use $ENV{QMAIL} to override /var/qmail for where to find the
abh authored
75 my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
6df92cd @abh half baked version of the new object mail engine
abh authored
76 my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
77 $configdir = "$name/config" if (-e "$name/config/$config");
c10b6fb @abh Support morercpthosts.cdb
abh authored
78
79 my $configfile = "$configdir/$config";
80
81 if ($type and $type eq "map") {
e006f74 @abh Use $ENV{QMAIL} to override /var/qmail for where to find the
abh authored
82 return +{} unless -e $configfile . ".cdb";
c10b6fb @abh Support morercpthosts.cdb
abh authored
83 eval { require CDB_File };
84
85 if ($@) {
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
86 $self->log(LOGERROR, "No $configfile.cdb support, could not load CDB_File module: $@");
c10b6fb @abh Support morercpthosts.cdb
abh authored
87 }
88 my %h;
89 unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
90 $self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
91 return +{};
c10b6fb @abh Support morercpthosts.cdb
abh authored
92 }
93 #warn Data::Dumper->Dump([\%h], [qw(h)]);
94 # should we cache this?
95 return \%h;
96 }
97
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
98 return $self->_config_from_file($configfile, $config);
99 }
100
101 sub _config_from_file {
102 my ($self, $configfile, $config) = @_;
1eafaba @abh don't try to open configuration files that does not exist.
abh authored
103 return unless -e $configfile;
9b150df @abh Fix bug hiding the error message when an existing configuration file
abh authored
104 open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return;
6df92cd @abh half baked version of the new object mail engine
abh authored
105 my @config = <CF>;
106 chomp @config;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
107 @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config;
6df92cd @abh half baked version of the new object mail engine
abh authored
108 close CF;
2a76892 @abh don't use Data::Dumper
abh authored
109 #$self->log(10, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
6df92cd @abh half baked version of the new object mail engine
abh authored
110 $self->{_config_cache}->{$config} = \@config;
111 return wantarray ? @config : $config[0];
112 }
113
114
e0d93d1 @abh semi working plugin stuff
abh authored
115 sub load_plugins {
116 my $self = shift;
117 my @plugins = $self->config('plugins');
118
119 my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
120 my $dir = "$name/plugins";
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
121 $self->log(LOGNOTICE, "loading plugins from $dir");
122
123 $self->_load_plugins($dir, @plugins);
124 }
e0d93d1 @abh semi working plugin stuff
abh authored
125
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
126 sub _load_plugins {
127 my $self = shift;
128 my ($dir, @plugins) = @_;
129
e0d93d1 @abh semi working plugin stuff
abh authored
130 for my $plugin (@plugins) {
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
131 $self->log(LOGINFO, "Loading $plugin");
3c80ae6 @abh remove $plugin defined twice warning
abh authored
132 ($plugin, my @args) = split /\s+/, $plugin;
03b8cda Don't keep the _qp around - just pass it in to each hook.
Matt Sergeant authored
133
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
134 if (lc($plugin) eq '$include') {
135 my $inc = shift @args;
136 my $config_dir = ($ENV{QMAIL} || '/var/qmail') . '/control';
137 my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
138 $config_dir = "$name/config" if (-e "$name/config/$inc");
139 if (-d "$config_dir/$inc") {
140 $self->log(LOGDEBUG, "Loading include dir: $config_dir/$inc");
141 opendir(DIR, "$config_dir/$inc") || die "opendir($config_dir/$inc): $!";
142 my @plugconf = sort grep { -f $_ } map { "$config_dir/$inc/$_" } grep { !/^\./ } readdir(DIR);
143 closedir(DIR);
144 foreach my $f (@plugconf) {
145 $self->_load_plugins($dir, $self->_config_from_file($f, "plugins"));
146 }
147 }
148 elsif (-f "$config_dir/$inc") {
149 $self->log(LOGDEBUG, "Loading include file: $config_dir/$inc");
150 $self->_load_plugins($dir, $self->_config_from_file("$config_dir/$inc", "plugins"));
151 }
152 else {
153 $self->log(LOGCRIT, "CRITICAL PLUGIN CONFIG ERROR: Include $config_dir/$inc not found");
154 }
155 next;
156 }
157
e0d93d1 @abh semi working plugin stuff
abh authored
158 my $plugin_name = $plugin;
9d5610a @abh 0.20-dev
abh authored
159
e0d93d1 @abh semi working plugin stuff
abh authored
160 # Escape everything into valid perl identifiers
161 $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
162
163 # second pass cares for slashes and words starting with a digit
164 $plugin_name =~ s{
165 (/+) # directory
166 (\d?) # package's first character
167 }[
168 "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
169 ]egx;
170
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
171 my $package = "Qpsmtpd::Plugin::$plugin_name";
172
29bbbec Check for register() function after fixing plugin name (major speedup…
Matt Sergeant authored
173 # don't reload plugins if they are already loaded
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
174 next if defined &{"${package}::register"};
03b8cda Don't keep the _qp around - just pass it in to each hook.
Matt Sergeant authored
175
e0d93d1 @abh semi working plugin stuff
abh authored
176 my $sub;
177 open F, "$dir/$plugin" or die "could not open $dir/$plugin: $!";
178 {
179 local $/ = undef;
180 $sub = <F>;
181 }
182 close F;
183
184 my $line = "\n#line 1 $dir/$plugin\n";
185
186 my $eval = join(
187 "\n",
188 "package $package;",
2fe35f1 @abh yay, plugin support works! :-D
abh authored
189 'use Qpsmtpd::Constants;',
e0d93d1 @abh semi working plugin stuff
abh authored
190 "require Qpsmtpd::Plugin;",
191 'use vars qw(@ISA);',
192 '@ISA = qw(Qpsmtpd::Plugin);',
4ee8b16 @abh support more data_post hook return codes
abh authored
193 "sub plugin_name { qq[$plugin_name] }",
2fe35f1 @abh yay, plugin support works! :-D
abh authored
194 $line,
e0d93d1 @abh semi working plugin stuff
abh authored
195 $sub,
196 "\n", # last line comment without newline?
197 );
198
5f2ceb0 @abh dnsbl plugin
abh authored
199 #warn "eval: $eval";
e0d93d1 @abh semi working plugin stuff
abh authored
200
2fe35f1 @abh yay, plugin support works! :-D
abh authored
201 $eval =~ m/(.*)/s;
e0d93d1 @abh semi working plugin stuff
abh authored
202 $eval = $1;
203
204 eval $eval;
205 die "eval $@" if $@;
206
2fe35f1 @abh yay, plugin support works! :-D
abh authored
207 my $plug = $package->new(qpsmtpd => $self);
9d5610a @abh 0.20-dev
abh authored
208 $plug->register($self, @args);
e0d93d1 @abh semi working plugin stuff
abh authored
209
2fe35f1 @abh yay, plugin support works! :-D
abh authored
210 }
211 }
e0d93d1 @abh semi working plugin stuff
abh authored
212
2fe35f1 @abh yay, plugin support works! :-D
abh authored
213 sub run_hooks {
214 my ($self, $hook) = (shift, shift);
9d5610a @abh 0.20-dev
abh authored
215 $self->{_hooks} = $Qpsmtpd::_hooks;
2fe35f1 @abh yay, plugin support works! :-D
abh authored
216 if ($self->{_hooks}->{$hook}) {
217 my @r;
218 for my $code (@{$self->{_hooks}->{$hook}}) {
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
219 $self->log(LOGINFO, "running plugin ", $code->{name});
03b8cda Don't keep the _qp around - just pass it in to each hook.
Matt Sergeant authored
220 eval { (@r) = $code->{code}->($self, $self->can('transaction') ? $self->transaction : {}, @_); };
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
221 $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next;
173a2d2 @abh better error messages when a plugin fails
abh authored
222 !defined $r[0]
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
223 and $self->log(LOGERROR, "plugin ".$code->{name}
173a2d2 @abh better error messages when a plugin fails
abh authored
224 ."running the $hook hook returned undef!")
225 and next;
5eec66f @abh add deny hook (Rasjid Wilcox)
abh authored
226
227 # should we have a hook for "OK" too?
228 if ($r[0] == DENY or $r[0] == DENYSOFT) {
229 $r[1] = "" if not defined $r[1];
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored
230 $self->log(LOGDEBUG, "Plugin $code->{name}, hook $hook returned $r[0], $r[1]");
5eec66f @abh add deny hook (Rasjid Wilcox)
abh authored
231 $self->run_hooks("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
232 }
233
2fe35f1 @abh yay, plugin support works! :-D
abh authored
234 last unless $r[0] == DECLINED;
235 }
9d5610a @abh 0.20-dev
abh authored
236 $r[0] = DECLINED if not defined $r[0];
2fe35f1 @abh yay, plugin support works! :-D
abh authored
237 return @r;
e0d93d1 @abh semi working plugin stuff
abh authored
238 }
2fe35f1 @abh yay, plugin support works! :-D
abh authored
239 return (0, '');
240 }
241
242 sub _register_hook {
243 my $self = shift;
244 my ($hook, $code) = @_;
e0d93d1 @abh semi working plugin stuff
abh authored
245
2fe35f1 @abh yay, plugin support works! :-D
abh authored
246 #my $plugin = shift; # see comment in Plugin.pm:register_hook
247
9d5610a @abh 0.20-dev
abh authored
248 $self->{_hooks} = $Qpsmtpd::_hooks;
2fe35f1 @abh yay, plugin support works! :-D
abh authored
249 my $hooks = $self->{_hooks};
250 push @{$hooks->{$hook}}, $code;
e0d93d1 @abh semi working plugin stuff
abh authored
251 }
252
6df92cd @abh half baked version of the new object mail engine
abh authored
253 1;
Something went wrong with that request. Please try again.