Skip to content
Newer
Older
100644 610 lines (498 sloc) 16.5 KB
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
1 package Qpsmtpd;
2 use strict;
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
3 use vars qw($VERSION $TraceLevel $Spool_dir $Size_threshold);
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
4
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored Sep 24, 2002
5 use Sys::Hostname;
6 use Qpsmtpd::Constants;
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
7
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
8 #use DashProfiler;
9
bc5fd11 @abh bump version to 0.43rc1; update Changes
abh authored Feb 1, 2008
10 $VERSION = "0.43rc1";
d4dda86 Implement config caching properly (for async).
Matt Sergeant authored Nov 16, 2007
11
12 my $hooks = {};
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
13 my %defaults = (
14 me => hostname,
15 timeout => 1200,
16 );
d4dda86 Implement config caching properly (for async).
Matt Sergeant authored Nov 16, 2007
17 my $_config_cache = {};
a64742c @vetinari prefork, forkserver: restart on SIGHUP: * reset to defaults * clear c…
vetinari authored Jun 15, 2008
18 my %config_dir_memo;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
19
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
20 #DashProfiler->add_profile("qpsmtpd");
21 #my $SAMPLER = DashProfiler->prepare("qpsmtpd");
a64742c @vetinari prefork, forkserver: restart on SIGHUP: * reset to defaults * clear c…
vetinari authored Jun 15, 2008
22 my $LOGGING_LOADED = 0;
23
24 sub _restart {
25 my $self = shift;
26 my %args = @_;
27 if ($args{restart}) {
28 # reset all global vars to defaults
29 $self->clear_config_cache;
30 $hooks = {};
31 $LOGGING_LOADED = 0;
32 %config_dir_memo = ();
33 $TraceLevel = LOGWARN;
34 $Spool_dir = undef;
35 $Size_threshold = undef;
36 }
37 }
38
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
39
40 sub DESTROY {
41 #warn $_ for DashProfiler->profile_as_text("qpsmtpd");
42 }
43
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
44 sub version { $VERSION };
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
45
6620034 * qpsmtpd-forkserver
John Peacock authored May 25, 2005
46 sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
47
367c9a3 (much) Less stat calls by caching load_logging
Matt Sergeant authored Feb 1, 2008
48
d0d7412 Fix auth and tls in light of globalised hooks
Matt Sergeant authored Apr 8, 2008
49 sub hooks { $hooks; }
50
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
51 sub load_logging {
52 # need to do this differently that other plugins so as to
53 # not trigger logging activity
367c9a3 (much) Less stat calls by caching load_logging
Matt Sergeant authored Feb 1, 2008
54 return if $LOGGING_LOADED;
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
55 my $self = shift;
c5dd26b Hook/plugin caching
Matt Sergeant authored Nov 16, 2007
56 return if $hooks->{"logging"};
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
57 my $configdir = $self->config_dir("logging");
58 my $configfile = "$configdir/logging";
59 my @loggers = $self->_config_from_file($configfile,'logging');
60
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
61 $configdir = $self->config_dir('plugin_dirs');
62 $configfile = "$configdir/plugin_dirs";
63 my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs');
ecb24ef @aqua Fix use of the default plugin dir path in the logging startup when no
aqua authored Nov 8, 2006
64 unless (@plugin_dirs) {
65 my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
66 @plugin_dirs = ( "$name/plugins" );
67 }
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
68
69 my @loaded;
70 for my $logger (@loggers) {
71 push @loaded, $self->_load_plugin($logger, @plugin_dirs);
72 }
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
73
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
74 foreach my $logger (@loaded) {
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
75 $self->log(LOGINFO, "Loaded $logger");
76 }
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
77
214e7e0 More crazy performance stuff
Matt Sergeant authored Feb 8, 2008
78 $configdir = $self->config_dir("loglevel");
79 $configfile = "$configdir/loglevel";
80 $TraceLevel = $self->_config_from_file($configfile,'loglevel');
81
82 unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
83 $TraceLevel = LOGWARN; # Default if no loglevel file found.
84 }
85
367c9a3 (much) Less stat calls by caching load_logging
Matt Sergeant authored Feb 1, 2008
86 $LOGGING_LOADED = 1;
87
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
88 return @loggers;
89 }
90
89fd516 Revamp Qpsmtpd::Constants so it is possible to retrieve the text
John Peacock authored Mar 29, 2005
91 sub trace_level {
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
92 my $self = shift;
89fd516 Revamp Qpsmtpd::Constants so it is possible to retrieve the text
John Peacock authored Mar 29, 2005
93 return $TraceLevel;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
94 }
95
6620034 * qpsmtpd-forkserver
John Peacock authored May 25, 2005
96 sub init_logger { # needed for compatibility purposes
97 shift->trace_level();
98 }
99
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored Sep 24, 2002
100 sub log {
101 my ($self, $trace, @log) = @_;
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
102 $self->varlog($trace,join(" ",@log));
103 }
104
105 sub varlog {
106 my ($self, $trace) = (shift,shift);
107 my ($hook, $plugin, @log);
108 if ( $#_ == 0 ) { # log itself
109 (@log) = @_;
110 }
111 elsif ( $#_ == 1 ) { # plus the hook
112 ($hook, @log) = @_;
113 }
114 else { # called from plugin
115 ($hook, $plugin, @log) = @_;
116 }
117
118 $self->load_logging; # in case we already don't have this loaded yet
119
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
120 my ($rc) = $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log);
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
121
122 unless ( $rc and $rc == DECLINED or $rc == OK ) {
123 # no logging plugins registered so fall back to STDERR
124 warn join(" ", $$ .
214e7e0 More crazy performance stuff
Matt Sergeant authored Feb 8, 2008
125 (defined $plugin ? " $plugin plugin ($hook):" :
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
126 defined $hook ? " running plugin ($hook):" : ""),
127 @log), "\n"
214e7e0 More crazy performance stuff
Matt Sergeant authored Feb 8, 2008
128 if $trace <= $TraceLevel;
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
129 }
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
130 }
131
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
132 sub clear_config_cache {
133 $_config_cache = {};
134 }
135
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
136 #
137 # method to get the configuration. It just calls get_qmail_config by
138 # default, but it could be overwritten to look configuration up in a
139 # database or whatever.
140 #
141 sub config {
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
142 my ($self, $c, $type) = @_;
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
143
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
144 #my $timer = $SAMPLER->("config", undef, 1);
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
145 if ($_config_cache->{$c}) {
146 return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
147 }
148
214e7e0 More crazy performance stuff
Matt Sergeant authored Feb 8, 2008
149 $_config_cache->{$c} = [$defaults{$c}] if exists($defaults{$c});
150
173a2d2 @abh better error messages when a plugin fails
abh authored Oct 17, 2002
151 #warn "SELF->config($c) ", ref $self;
806fcf2 @abh Reorganize most of Qpsmtpd.pm into Qpsmtpd/SMTP.pm.
abh authored Sep 24, 2002
152
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
153 my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
9d5610a @abh 0.20-dev
abh authored Nov 6, 2002
154 @config = () unless $rc == OK;
155
3e5de3a @abh separate queue method called from data.
abh authored Jul 6, 2002
156 if (wantarray) {
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
157 @config = $self->get_qmail_config($c, $type) unless @config;
bae4a84 Fixed defaults bug (freeside)
Matt Sergeant authored Jul 24, 2003
158 @config = $defaults{$c} if (!@config and $defaults{$c});
3e5de3a @abh separate queue method called from data.
abh authored Jul 6, 2002
159 return @config;
160 }
161 else {
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
162 return ($config[0] || $self->get_qmail_config($c, $type) || $defaults{$c});
3e5de3a @abh separate queue method called from data.
abh authored Jul 6, 2002
163 }
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
164 }
165
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
166 sub config_dir {
167 my ($self, $config) = @_;
d4dda86 Implement config caching properly (for async).
Matt Sergeant authored Nov 16, 2007
168 if (exists $config_dir_memo{$config}) {
169 return $config_dir_memo{$config};
170 }
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
171 my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
b7f4684 Fixup qpsmtpd-prefork, et al, to correctly load Constants.
John Peacock authored Nov 22, 2006
172 my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
173 $configdir = "$path/config" if (-e "$path/config/$config");
deb3380 @aqua Apply slight variation on patch from Peter Holzer to allow specificat…
aqua authored Jul 29, 2005
174 if (exists $ENV{QPSMTPD_CONFIG}) {
175 $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint
176 $configdir = $1 if -e "$1/$config";
177 }
d4dda86 Implement config caching properly (for async).
Matt Sergeant authored Nov 16, 2007
178 return $config_dir_memo{$config} = $configdir;
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
179 }
180
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
181 sub plugin_dirs {
182 my $self = shift;
183 my @plugin_dirs = $self->config('plugin_dirs');
184
185 unless (@plugin_dirs) {
b7f4684 Fixup qpsmtpd-prefork, et al, to correctly load Constants.
John Peacock authored Nov 22, 2006
186 my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
187 @plugin_dirs = ( "$path/plugins" );
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
188 }
189 return @plugin_dirs;
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
190 }
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
191
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
192 sub get_qmail_config {
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
193 my ($self, $config, $type) = @_;
c78dad0 Revert to proper versions
Matt Sergeant authored Jul 7, 2005
194 $self->log(LOGDEBUG, "trying to get config for $config");
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
195 my $configdir = $self->config_dir($config);
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
196
197 my $configfile = "$configdir/$config";
198
16e577c @abh explain why the CDB config entries are not cached
abh authored Feb 14, 2008
199 # CDB config support really should be moved to a plugin
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
200 if ($type and $type eq "map") {
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
201 unless (-e $configfile . ".cdb") {
8e3c0cf fix config caching again - defaults weren't applied prior to this patch
Matt Sergeant authored Mar 18, 2008
202 $_config_cache->{$config} ||= [];
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
203 return +{};
204 }
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
205 eval { require CDB_File };
206
207 if ($@) {
a979f83 @abh fix the CDB support so we can work without it (but with a big warning)
abh authored Jul 18, 2004
208 $self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@");
209 return +{};
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
210 }
a979f83 @abh fix the CDB support so we can work without it (but with a big warning)
abh authored Jul 18, 2004
211
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
212 my %h;
213 unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
214 $self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
215 return +{};
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
216 }
16e577c @abh explain why the CDB config entries are not cached
abh authored Feb 14, 2008
217 # We explicitly don't cache cdb entries. The assumption is that
218 # the data is in a CDB file in the first place because there's
219 # lots of data and the cache hit ratio would be low.
c10b6fb @abh Support morercpthosts.cdb
abh authored Mar 25, 2003
220 return \%h;
221 }
222
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
223 return $self->_config_from_file($configfile, $config);
224 }
225
226 sub _config_from_file {
6f23c46 @aqua Generalize '$include' support from plugin configuration to cover all …
aqua authored Jul 31, 2005
227 my ($self, $configfile, $config, $visited) = @_;
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
228 unless (-e $configfile) {
8e3c0cf fix config caching again - defaults weren't applied prior to this patch
Matt Sergeant authored Mar 18, 2008
229 $_config_cache->{$config} ||= [];
8700e5c Better config caching
Matt Sergeant authored Dec 3, 2007
230 return;
231 }
6f23c46 @aqua Generalize '$include' support from plugin configuration to cover all …
aqua authored Jul 31, 2005
232
233 $visited ||= [];
234 push @{$visited}, $configfile;
235
9b150df @abh Fix bug hiding the error message when an existing configuration file
abh authored Apr 23, 2003
236 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 Jul 3, 2002
237 my @config = <CF>;
238 chomp @config;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
239 @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config;
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
240 close CF;
6f23c46 @aqua Generalize '$include' support from plugin configuration to cover all …
aqua authored Jul 31, 2005
241
242 my $pos = 0;
243 while ($pos < @config) {
244 # recursively pursue an $include reference, if found. An inclusion which
245 # begins with a leading slash is interpreted as a path to a file and will
246 # supercede the usual config path resolution. Otherwise, the normal
247 # config_dir() lookup is employed (the location in which the inclusion
248 # appeared receives no special precedence; possibly it should, but it'd
249 # be complicated beyond justifiability for so simple a config system.
250 if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) {
251 my ($includedir, $inclusion) = ('', $1);
252
253 splice @config, $pos, 1; # remove the $include line
254 if ($inclusion !~ /^\//) {
255 $includedir = $self->config_dir($inclusion);
256 $inclusion = "$includedir/$inclusion";
257 }
258
259 if (grep($_ eq $inclusion, @{$visited})) {
260 $self->log(LOGERROR, "Circular \$include reference in config $config:");
261 $self->log(LOGERROR, "From $visited->[0]:");
262 $self->log(LOGERROR, " includes $_")
263 for (@{$visited}[1..$#{$visited}], $inclusion);
264 return wantarray ? () : undef;
265 }
266 push @{$visited}, $inclusion;
267
268 for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
269 my @insertion = $self->_config_from_file($inc, $config, $visited);
270 splice @config, $pos, 0, @insertion; # insert the inclusion
271 $pos += @insertion;
272 }
273 } else {
274 $pos++;
275 }
276 }
277
d4dda86 Implement config caching properly (for async).
Matt Sergeant authored Nov 16, 2007
278 $_config_cache->{$config} = \@config;
6f23c46 @aqua Generalize '$include' support from plugin configuration to cover all …
aqua authored Jul 31, 2005
279
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
280 return wantarray ? @config : $config[0];
281 }
282
6f23c46 @aqua Generalize '$include' support from plugin configuration to cover all …
aqua authored Jul 31, 2005
283 sub expand_inclusion_ {
284 my $self = shift;
285 my $inclusion = shift;
286 my $context = shift;
287 my @includes;
288
289 if (-d $inclusion) {
290 $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context");
291
292 if (opendir(INCD, $inclusion)) {
293 @includes = map { "$inclusion/$_" }
d4dda86 Implement config caching properly (for async).
Matt Sergeant authored Nov 16, 2007
294 (grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
6f23c46 @aqua Generalize '$include' support from plugin configuration to cover all …
aqua authored Jul 31, 2005
295 closedir INCD;
296 } else {
297 $self->log(LOGERROR, "Couldn't open directory $inclusion,".
298 " referenced from $context ($!)");
299 }
300 } else {
301 $self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
302 @includes = ( $inclusion );
303 }
304 return @includes;
305 }
306
307
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
308 sub load_plugins {
309 my $self = shift;
e6e2091 Attempt to clean up circular refs problems
Matt Sergeant authored Aug 31, 2004
310
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
311 my @plugins = $self->config('plugins');
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
312 my @loaded;
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
313
c837f5d Fixed hook caching
Matt Sergeant authored Nov 19, 2007
314 if ($hooks->{queue}) {
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
315 #$self->log(LOGWARN, "Plugins already loaded");
c5dd26b Hook/plugin caching
Matt Sergeant authored Nov 16, 2007
316 return @plugins;
317 }
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
318
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
319 for my $plugin_line (@plugins) {
b7f4684 Fixup qpsmtpd-prefork, et al, to correctly load Constants.
John Peacock authored Nov 22, 2006
320 my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs);
321 push @loaded, $this_plugin if $this_plugin;
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
322 }
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
323
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
324 return @loaded;
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
325 }
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
326
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
327 sub _load_plugin {
9c700b1 New for 0.28: Log levels and $Include for config/plugins
Matt Sergeant authored Mar 5, 2004
328 my $self = shift;
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
329 my ($plugin_line, @plugin_dirs) = @_;
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
330
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
331 my ($plugin, @args) = split ' ', $plugin_line;
332
333 my $package;
334
335 if ($plugin =~ m/::/) {
336 # "full" package plugin (My::Plugin)
337 $package = $plugin;
338 $package =~ s/[^_a-z0-9:]+//gi;
339 my $eval = qq[require $package;\n]
340 .qq[sub ${plugin}::plugin_name { '$plugin' }];
341 $eval =~ m/(.*)/s;
342 $eval = $1;
343 eval $eval;
344 die "Failed loading $package - eval $@" if $@;
345 $self->log(LOGDEBUG, "Loading $package ($plugin_line)")
346 unless $plugin_line =~ /logging/;
347 }
348 else {
349 # regular plugins/$plugin plugin
350 my $plugin_name = $plugin;
351 $plugin =~ s/:\d+$//; # after this point, only used for filename
352
353 # Escape everything into valid perl identifiers
354 $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
355
356 # second pass cares for slashes and words starting with a digit
357 $plugin_name =~ s{
358 (/+) # directory
359 (\d?) # package's first character
360 }[
361 "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
362 ]egx;
363
364 $package = "Qpsmtpd::Plugin::$plugin_name";
365
366 # don't reload plugins if they are already loaded
367 unless ( defined &{"${package}::plugin_name"} ) {
368 PLUGIN_DIR: for my $dir (@plugin_dirs) {
369 if (-e "$dir/$plugin") {
370 Qpsmtpd::Plugin->compile($plugin_name, $package,
ef7d885 Allow plugin tests to be in subdir (as with plugins).
Matt Sergeant authored May 17, 2007
371 "$dir/$plugin", $self->{_test_mode}, $plugin);
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
372 $self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin")
373 unless $plugin_line =~ /logging/;
374 last PLUGIN_DIR;
375 }
bf2419d @abh r3744@embla: ask | 2006-06-28 13:04:50 -0700
abh authored Jun 28, 2006
376 }
8809fce @vetinari Better error message than
vetinari authored Jul 31, 2007
377 die "Plugin $plugin_name not found in our plugin dirs (",
378 join(", ", @plugin_dirs),")"
379 unless defined &{"${package}::plugin_name"};
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
380 }
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
381 }
af5f025 @aqua (Working) support for multiple plugin directories, with a fix from Nick
aqua authored Nov 5, 2006
382
383 my $plug = $package->new();
384 $plug->_register($self, @args);
9224e43 Plugin testing framework.
Matt Sergeant authored Sep 8, 2004
385
be67f02 Fix tests (idea from Guy Hulbert, with tweak from me).
Matt Sergeant authored Jan 11, 2007
386 return $plug;
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
387 }
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
388
c78dad0 Revert to proper versions
Matt Sergeant authored Jul 7, 2005
389 sub transaction {
390 return {}; # base class implements empty transaction
391 }
392
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
393 sub run_hooks {
394 my ($self, $hook) = (shift, shift);
e6e2091 Attempt to clean up circular refs problems
Matt Sergeant authored Aug 31, 2004
395 if ($hooks->{$hook}) {
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
396 my @r;
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
397 my @local_hooks = @{$hooks->{$hook}};
398 $self->{_continuation} = [$hook, [@_], @local_hooks];
399 return $self->run_continuation();
400 }
2b709d6 Async qpsmtpd (still entirely compatible with non-async version)
Matt Sergeant authored Dec 8, 2006
401 return $self->hook_responder($hook, [0, ''], [@_]);
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
402 }
403
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
404 sub run_hooks_no_respond {
405 my ($self, $hook) = (shift, shift);
406 if ($hooks->{$hook}) {
407 my @r;
408 for my $code (@{$hooks->{$hook}}) {
409 eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
410 $@ and warn("FATAL PLUGIN ERROR: ", $@) and next;
411 if ($r[0] == YIELD) {
412 die "YIELD not valid from $hook hook";
413 }
414 last unless $r[0] == DECLINED;
415 }
416 $r[0] = DECLINED if not defined $r[0];
417 return @r;
418 }
419 return (0, '');
420 }
421
bb72464 Don't continually check ->isa() for continue/pause_read - use OO prop…
Matt Sergeant authored May 2, 2008
422 sub continue_read {} # subclassed in -async
423 sub pause_read { die "Continuations only work in qpsmtpd-async" }
424
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
425 sub run_continuation {
426 my $self = shift;
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
427 #my $t1 = $SAMPLER->("run_hooks", undef, 1);
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
428 die "No continuation in progress" unless $self->{_continuation};
bb72464 Don't continually check ->isa() for continue/pause_read - use OO prop…
Matt Sergeant authored May 2, 2008
429 $self->continue_read();
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
430 my $todo = $self->{_continuation};
431 $self->{_continuation} = undef;
432 my $hook = shift @$todo || die "No hook in the continuation";
433 my $args = shift @$todo || die "No hook args in the continuation";
434 my @r;
435 while (@$todo) {
436 my $code = shift @$todo;
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
437 #my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1);
438 #warn("Got sampler called: ${hook}_$code->{name}\n");
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
439 $self->varlog(LOGDEBUG, $hook, $code->{name});
440 my $tran = $self->transaction;
441 eval { (@r) = $code->{code}->($self, $tran, @$args); };
442 $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next;
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
443
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
444 !defined $r[0]
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
445 and $self->log(LOGERROR, "plugin ".$code->{name}
446 ." running the $hook hook returned undef!")
447 and next;
448
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
449 # note this is wrong as $tran is always true in the
450 # current code...
451 if ($tran) {
452 my $tnotes = $tran->notes( $code->{name} );
453 $tnotes->{"hook_$hook"}->{'return'} = $r[0]
454 if (!defined $tnotes || ref $tnotes eq "HASH");
455 }
456 else {
457 my $cnotes = $self->connection->notes( $code->{name} );
458 $cnotes->{"hook_$hook"}->{'return'} = $r[0]
459 if (!defined $cnotes || ref $cnotes eq "HASH");
460 }
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
461
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
462 if ($r[0] == YIELD) {
bb72464 Don't continually check ->isa() for continue/pause_read - use OO prop…
Matt Sergeant authored May 2, 2008
463 $self->pause_read();
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
464 $self->{_continuation} = [$hook, $args, @$todo];
465 return @r;
466 }
467 elsif ($r[0] == DENY or $r[0] == DENYSOFT or
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
468 $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT)
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
469 {
470 $r[1] = "" if not defined $r[1];
471 $self->log(LOGDEBUG, "Plugin ".$code->{name}.
89fd516 Revamp Qpsmtpd::Constants so it is possible to retrieve the text
John Peacock authored Mar 29, 2005
472 ", hook $hook returned ".return_code($r[0]).", $r[1]");
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
473 $self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
474 }
475 else {
476 $r[1] = "" if not defined $r[1];
477 $self->log(LOGDEBUG, "Plugin ".$code->{name}.
89fd516 Revamp Qpsmtpd::Constants so it is possible to retrieve the text
John Peacock authored Mar 29, 2005
478 ", hook $hook returned ".return_code($r[0]).", $r[1]");
3553eee More small performance optimisations
Matt Sergeant authored Feb 1, 2008
479 $self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
480 }
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
481
482 last unless $r[0] == DECLINED;
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
483 }
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
484 $r[0] = DECLINED if not defined $r[0];
ddc1b91 @vetinari make hook_*_parse() work again
vetinari authored Mar 20, 2008
485 # hook_*_parse() may return a CODE ref..
486 # ... which breaks when splitting as string:
487 @r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
488 return $self->hook_responder($hook, \@r, $args);
489 }
490
491 sub hook_responder {
492 my ($self, $hook, $msg, $args) = @_;
493
238eb79 Small performance improvement for logging and config hooks which don'…
Matt Sergeant authored Jan 30, 2008
494 #my $t1 = $SAMPLER->("hook_responder", undef, 1);
495
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
496 my $code = shift @$msg;
497
498 my $responder = $hook . '_respond';
499 if (my $meth = $self->can($responder)) {
2b709d6 Async qpsmtpd (still entirely compatible with non-async version)
Matt Sergeant authored Dec 8, 2006
500 return $meth->($self, $code, $msg, $args);
e299135 Initial work for continuations (and thus the async server).
Matt Sergeant authored Nov 30, 2006
501 }
502 return $code, @$msg;
2fe35f1 @abh yay, plugin support works! :-D
abh authored Jul 8, 2002
503 }
504
505 sub _register_hook {
506 my $self = shift;
0e5b4e6 Add unshift parameter to register_hook, allowing you to put the hook …
Matt Sergeant authored Jun 11, 2004
507 my ($hook, $code, $unshift) = @_;
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
508
0e5b4e6 Add unshift parameter to register_hook, allowing you to put the hook …
Matt Sergeant authored Jun 11, 2004
509 if ($unshift) {
510 unshift @{$hooks->{$hook}}, $code;
511 }
512 else {
513 push @{$hooks->{$hook}}, $code;
514 }
e0d93d1 @abh semi working plugin stuff
abh authored Jul 6, 2002
515 }
516
bb36c60 Abstracted spool_dir creation and added temp_file() and temp_dir() su…
John Peacock authored Feb 22, 2005
517 sub spool_dir {
518 my $self = shift;
519
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
520 unless ( $Spool_dir ) { # first time through
ec7aff1 * lib/Qpsmtpd.pm
John Peacock authored Mar 1, 2005
521 $self->log(LOGINFO, "Initializing spool_dir");
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
522 $Spool_dir = $self->config('spool_dir')
ec7aff1 * lib/Qpsmtpd.pm
John Peacock authored Mar 1, 2005
523 || Qpsmtpd::Utils::tildeexp('~/tmp/');
bb36c60 Abstracted spool_dir creation and added temp_file() and temp_dir() su…
John Peacock authored Feb 22, 2005
524
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
525 $Spool_dir .= "/" unless ($Spool_dir =~ m!/$!);
ec7aff1 * lib/Qpsmtpd.pm
John Peacock authored Mar 1, 2005
526
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
527 $Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
528 $Spool_dir = $1; # cleanse the taint
bb36c60 Abstracted spool_dir creation and added temp_file() and temp_dir() su…
John Peacock authored Feb 22, 2005
529
530 # Make sure the spool dir has appropriate rights
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
531 if (-e $Spool_dir) {
532 my $mode = (stat($Spool_dir))[2];
ec7aff1 * lib/Qpsmtpd.pm
John Peacock authored Mar 1, 2005
533 $self->log(LOGWARN,
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
534 "Permissions on spool_dir $Spool_dir are not 0700")
ec7aff1 * lib/Qpsmtpd.pm
John Peacock authored Mar 1, 2005
535 if $mode & 07077;
bb36c60 Abstracted spool_dir creation and added temp_file() and temp_dir() su…
John Peacock authored Feb 22, 2005
536 }
537
538 # And finally, create it if it doesn't already exist
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
539 -d $Spool_dir or mkdir($Spool_dir, 0700)
540 or die "Could not create spool_dir $Spool_dir: $!";
541 }
ec7aff1 * lib/Qpsmtpd.pm
John Peacock authored Mar 1, 2005
542
e331f6b Add plugable logging support include sample plugin which replicates the
John Peacock authored Mar 24, 2005
543 return $Spool_dir;
bb36c60 Abstracted spool_dir creation and added temp_file() and temp_dir() su…
John Peacock authored Feb 22, 2005
544 }
545
546 # For unique filenames. We write to a local tmp dir so we don't need
547 # to make them unpredictable.
548 my $transaction_counter = 0;
549
550 sub temp_file {
551 my $self = shift;
552 my $filename = $self->spool_dir()
553 . join(":", time, $$, $transaction_counter++);
554 return $filename;
555 }
556
557 sub temp_dir {
558 my $self = shift;
559 my $mask = shift || 0700;
560 my $dirname = $self->temp_file();
561 -d $dirname or mkdir($dirname, $mask)
562 or die "Could not create temporary directory $dirname: $!";
563 return $dirname;
564 }
565
9cbf206 * lib/Qpsmtpd/TcpServer.pm
John Peacock authored Sep 22, 2005
566 sub size_threshold {
567 my $self = shift;
568 unless ( defined $Size_threshold ) {
4b3fdf5 * lib/Qpsmtpd.pm
John Peacock authored Sep 22, 2005
569 $Size_threshold = $self->config('size_threshold') || 0;
9cbf206 * lib/Qpsmtpd/TcpServer.pm
John Peacock authored Sep 22, 2005
570 $self->log(LOGNOTICE, "size_threshold set to $Size_threshold");
571 }
572 return $Size_threshold;
573 }
5959cc1 * lib/Qpsmtpd/Auth.pm
John Peacock authored Oct 31, 2005
574
fea300e Add authenticated method to base Qpsmtpd object.
John Peacock authored Feb 7, 2007
575 sub authenticated {
576 my $self = shift;
577 return (defined $self->{_auth} ? $self->{_auth} : "" );
578 }
579
5959cc1 * lib/Qpsmtpd/Auth.pm
John Peacock authored Oct 31, 2005
580 sub auth_user {
581 my $self = shift;
582 return (defined $self->{_auth_user} ? $self->{_auth_user} : "" );
583 }
584
585 sub auth_mechanism {
586 my $self = shift;
587 return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" );
588 }
9cbf206 * lib/Qpsmtpd/TcpServer.pm
John Peacock authored Sep 22, 2005
589
6df92cd @abh half baked version of the new object mail engine
abh authored Jul 3, 2002
590 1;
3b7bfe9 @abh update the MANIFEST
abh authored Jul 2, 2005
591
592 __END__
593
594 =head1 NAME
595
596 Qpsmtpd
597
598 =head1 DESCRIPTION
599
600 This is the base class for the qpsmtpd mail server. See
601 L<http://smtpd.develooper.com/> and the I<README> file for more information.
602
603 =head1 COPYRIGHT
604
605 Copyright 2001-2005 Ask Bjoern Hansen, Develooper LLC. See the
606 LICENSE file for more information.
607
608
609
Something went wrong with that request. Please try again.