Merge from vendor branch GDB:
[dragonfly.git] / contrib / sendmail-8.13.4 / contrib / mailprio
1 Received: from austin.bsdi.com (root{9l9gVDC7v8t3dlv0OtXTlby6X1zBWd56}@austin.BSDI.COM [205.230.224.49]) by knecht.Sendmail.ORG (8.8.2/8.8.2) with ESMTP id JAA05023 for <eric@sendmail.org>; Thu, 31 Oct 1996 09:29:47 -0800 (PST)
2 Received: from austin.bsdi.com (localhost [127.0.0.1]) by austin.bsdi.com (8.7.4/8.7.3) with ESMTP id KAA19250; Thu, 31 Oct 1996 10:28:18 -0700 (MST)
3 Message-Id: <199610311728.KAA19250@austin.bsdi.com>
4 To: Eric Allman <eric@sendmail.org>
5 cc: marc@xfree86.org
6 Subject: Updated mailprio_0_93.shar
7 From: Tony Sanders <sanders@earth.com>
8 Organization: Berkeley Software Design, Inc.
9 Date: Thu, 31 Oct 1996 10:28:14 -0700
10 Sender: sanders@austin.bsdi.com
11
12 Eric, please update contrib/mailprio in the sendmail distribution
13 to this version at your convenience.  Thanks.
14
15 I've also made this available in:
16         ftp://ftp.earth.com/pub/postmaster/
17
18 mailprio_0_93.shar follows...
19
20 #!/bin/sh
21 # This is a shell archive (produced by GNU sharutils 4.1).
22 # To extract the files from this archive, save it to some FILE, remove
23 # everything before the `!/bin/sh' line above, then type `sh FILE'.
24 #
25 # Made on 1996-10-31 10:07 MST by <sanders@earth.com>.
26 #
27 # Existing files will *not* be overwritten unless `-c' is specified.
28 #
29 # This shar contains:
30 # length mode       name
31 # ------ ---------- ------------------------------------------
32 #   8260 -rwxr-xr-x mailprio
33 #   3402 -rw-r--r-- mailprio.README
34 #   4182 -rwxr-xr-x mailprio_mkdb
35 #
36 touch -am 1231235999 $$.touch >/dev/null 2>&1
37 if test ! -f 1231235999 && test -f $$.touch; then
38   shar_touch=touch
39 else
40   shar_touch=:
41   echo
42   echo 'WARNING: not restoring timestamps.  Consider getting and'
43   echo "installing GNU \`touch', distributed in GNU File Utilities..."
44   echo
45 fi
46 rm -f 1231235999 $$.touch
47 #
48 # ============= mailprio ==============
49 if test -f 'mailprio' && test X"$1" != X"-c"; then
50   echo 'x - skipping mailprio (file already exists)'
51 else
52   echo 'x - extracting mailprio (text)'
53   sed 's/^X//' << 'SHAR_EOF' > 'mailprio' &&
54 #!/usr/bin/perl
55 #
56 # mailprio,v 1.4 1996/10/31 17:03:52 sanders Exp
57 # Version 0.93 -- Thu Oct 31 09:42:25 MST 1996
58 #
59 # mailprio -- setup mail priorities for a mailing list
60 #
61 # Copyright 1994, 1996, Tony Sanders <sanders@earth.com>
62 # Rights are hereby granted to download, use, modify, sell, copy, and
63 # redistribute this software so long as the original copyright notice
64 # and this list of conditions remain intact and modified versions are
65 # noted as such.
66 #
67 # I would also very much appreciate it if you could send me a copy of
68 # any changes you make so I can possibly integrate them into my version.
69 #
70 # Options:
71 #     -p priority_database      -- Specify database to use if not default
72 #     -q                        -- Process sendmail V8.8.X queue format files
73 #
74 # Sort mailing lists or sendmail queue files by mailprio database.
75 # Files listed on the command line are locked and then sorted in place, in
76 # the absence of any file arguments it will read STDIN and write STDOUT.
77 #
78 # Examples:
79 #     mailprio < mailing-list > sorted_list
80 #     mailprio mailing-list1 mailing-list2 mailing-list3 ...
81 #     mailprio -q /var/spool/mqueue/qf*
82 # To double check results:
83 #     sort sorted_list > checkit; sort orig-mailing-list | diff - checkit
84 #
85 # To get the maximum value from a transaction delay based priority
86 # function you need to reorder the distribution list (and the mail
87 # queue files for that matter) fairly often; you could even have
88 # your mailing list software reorder the list before each outgoing
89 # message.
90 #
91 $usage = "Usage: mailprio [-p priodb] [-q] [mailinglists ...]\n";
92 $home = "/home/sanders/lists";
93 $priodb = "$home/mailprio";
94 $locking = "flock";     # "flock" or "fcntl"
95 X
96 # In shell, it would go more or less like this:
97 #     old_mailprio > /tmp/a
98 #     fgrep -f lists/inet-access /tmp/a | sed -e 's/^.......//' > /tmp/b
99 #         ; /tmp/b contains list of known users, faster delivery first
100 #     fgrep -v -f /tmp/b lists/inet-access > /tmp/c
101 #         ; put all unknown stuff at the top of new list for now
102 #     echo '# -----' >> /tmp/c
103 #     cat /tmp/b >> /tmp/c
104 X
105 $qflag = 0;
106 while ($main'ARGV[0] =~ /^-/) {
107 X        $args = shift;
108 X        if ($args =~ m/\?/) { print $usage; exit 0; }
109 X        if ($args =~ m/q/) { $qflag = 1; }
110 X        if ($args =~ m/p/) {
111 X            $priodb = shift || die $usage, "-p requires argument\n"; }
112 }
113 X
114 push(@main'ARGV, '-') if ($#ARGV < 0);
115 while ($file = shift @ARGV) {
116 X    if ($file eq "-") {
117 X        $source = "main'STDIN";
118 X        $sink = "main'STDOUT";
119 X    } else {
120 X        $sink = $source = "FH";
121 X        open($source, "+< $file") || do { warn "$file: $!\n"; next; };
122 X        if (!defined &seize($source, &LOCK_EX | &LOCK_NB)) {
123 X            # couldn't get lock, just skip it
124 X            close($source);
125 X            next;
126 X        }
127 X    }
128 X
129 X    local(*list);
130 X    &process($source, *list);
131 X
132 X    # setup to write output
133 X    if ($file ne "-") {
134 X       # zero the file (FH is hardcoded because truncate requires it, sigh)
135 X        seek(FH, 0, 0) || die "$file: seek: $!\n";
136 X        truncate(FH, 0) || die "$file: truncate: $!\n";
137 X    }
138 X
139 X    # do the dirty work
140 X    &output($sink, *list);
141 X
142 X    close($sink) || warn "$file: $!\n";         # close clears the lock
143 X    close($source);
144 }
145 X
146 sub process {
147 X    # Setup %list and @list
148 X    local($source, *list) = @_;
149 X    local($addr, $canon);
150 X    while ($addr = <$source>) {
151 X        chop $addr;
152 X        next if $addr =~ /^# ----- /;                   # that's our line
153 X        push(@list, $addr), next if $addr =~ /^\s*#/;   # save comments
154 X       if ($qflag) {
155 X           next if $addr =~ m/^\./;
156 X           push(@list, $addr), next if !($addr =~ s/^(R[^:]*:)//);
157 X           $Rflags = $1;
158 X       }
159 X        $canon = &canonicalize((&simplify_address($addr))[0]);
160 X        unless (defined $canon) {
161 X            warn "$file: no address found: $addr\n";
162 X            push(@list, ($qflag?$Rflags:'') . $addr);       # save it as is
163 X            next;
164 X        }
165 X        if (defined $list{$canon}) {
166 X            warn "$file: duplicate: ``$addr -> $canon''\n";
167 X            push(@list, ($qflag?$Rflags:'') . $addr);       # save it as is
168 X            next;
169 X        }
170 X        $list{$canon} = $addr;
171 X    }
172 }
173 X
174 sub output {
175 X    local($sink, *list) = @_;
176 X
177 X    local($to, *prio, *userprio, *useracct);
178 X    dbmopen(%prio, $priodb, 0644) || die "$priodb: $!\n";
179 X    foreach $to (keys %list) {
180 X        if (defined $prio{$to}) {
181 X            # add to list of found users (%userprio) and remove from %list
182 X            # so that we know what users were not yet prioritized
183 X            $userprio{$to} = $prio{$to};        # priority
184 X            $useracct{$to} = $list{$to};        # string
185 X            delete $list{$to};
186 X        }
187 X    }
188 X    dbmclose(%prio);
189 X
190 X    # Put all the junk we found at the very top
191 X    # (this might not always be a feature)
192 X    print $sink join("\n", @list), "\n" if int(@list);
193 X
194 X    # prioritized list of users
195 X    if (int(keys %userprio)) {
196 X        print $sink '# ----- prioritized users', "\n" unless $qflag;
197 X        foreach $to (sort by_userprio keys %userprio) {
198 X            die "Opps! Something is seriously wrong with useracct: $to\n"
199 X                unless defined $useracct{$to};
200 X           print $sink 'RFD:' if $qflag;
201 X            print $sink $useracct{$to}, "\n";
202 X        }
203 X    }
204 X
205 X    # unprioritized users go last, fast accounts will get moved up eventually
206 X    # XXX: should go before the "really slow" prioritized users?
207 X    if (int(keys %list)) {
208 X        print $sink '# ----- unprioritized users', "\n" unless $qflag;
209 X        foreach $to (keys %list) {
210 X            print $sink 'RFD:' if $qflag;
211 X            print $sink $list{$to}, "\n";
212 X        }
213 X    }
214 X
215 X    print $sink ".\n" if $qflag;
216 }
217 X
218 sub by_userprio {
219 X    # sort first by priority, then by key.
220 X    $userprio{$a} <=> $userprio{$b} || $a cmp $b;
221 }
222 X
223 # REPL-LIB ---------------------------------------------------------------
224 X
225 sub canonicalize {
226 X    local($addr) = @_;
227 X    # lowercase, strip leading/trailing whitespace
228 X    $addr =~ y/A-Z/a-z/; $addr =~ s/^\s+//; $addr =~ s/\s+$//; $addr;
229 }
230 X
231 # @addrs = simplify_address($addr);
232 sub simplify_address {
233 X    local($_) = shift;
234 X    1 while s/\([^\(\)]*\)//g;          # strip comments
235 X    1 while s/"[^"]*"//g;               # strip comments
236 X    split(/,/);                         # split into parts
237 X    foreach (@_) {
238 X        1 while s/.*<(.*)>.*/\1/;
239 X        s/^\s+//;
240 X        s/\s+$//;
241 X    }
242 X    @_;
243 }
244 X
245 ### ---- ###
246 #
247 # Error codes
248 #
249 do 'errno.ph';
250 eval 'sub ENOENT {2;}'          unless defined &ENOENT;
251 eval 'sub EINTR {4;}'           unless defined &EINTR;
252 eval 'sub EINVAL {22;}'         unless defined &EINVAL;
253 X
254 #
255 # File locking
256 #
257 do 'sys/unistd.ph';
258 eval 'sub SEEK_SET {0;}'        unless defined &SEEK_SET;
259 X
260 do 'sys/file.ph';
261 eval 'sub LOCK_SH {0x01;}'      unless defined &LOCK_SH;
262 eval 'sub LOCK_EX {0x02;}'      unless defined &LOCK_EX;
263 eval 'sub LOCK_NB {0x04;}'      unless defined &LOCK_NB;
264 eval 'sub LOCK_UN {0x08;}'      unless defined &LOCK_UN;
265 X
266 do 'fcntl.ph';
267 eval 'sub F_GETFD {1;}'         unless defined &F_GETFD;
268 eval 'sub F_SETFD {2;}'         unless defined &F_SETFD;
269 eval 'sub F_GETFL {3;}'         unless defined &F_GETFL;
270 eval 'sub F_SETFL {4;}'         unless defined &F_SETFL;
271 eval 'sub O_NONBLOCK {0x0004;}' unless defined &O_NONBLOCK;
272 eval 'sub F_SETLK {8;}'         unless defined &F_SETLK;        # nonblocking
273 eval 'sub F_SETLKW {9;}'        unless defined &F_SETLKW;       # lockwait
274 eval 'sub F_RDLCK {1;}'         unless defined &F_RDLCK;
275 eval 'sub F_UNLCK {2;}'         unless defined &F_UNLCK;
276 eval 'sub F_WRLCK {3;}'         unless defined &F_WRLCK;
277 $s_flock = "sslll";             # struct flock {type, whence, start, len, pid}
278 X
279 # return undef on failure
280 sub seize {
281 X    local ($FH, $lock) = @_;
282 X    local ($ret);
283 X    if ($locking eq "flock") {
284 X        $ret = flock($FH, $lock);
285 X       return ($ret == 0 ? undef : 1);
286 X    } else {
287 X        local ($flock, $type) = 0;
288 X        if ($lock & &LOCK_SH) { $type = &F_RDLCK; }
289 X        elsif ($lock & &LOCK_EX) { $type = &F_WRLCK; }
290 X        elsif ($lock & &LOCK_UN) { $type = &F_UNLCK; }
291 X        else { $! = &EINVAL; return undef; }
292 X        $flock = pack($s_flock, $type, &SEEK_SET, 0, 0, 0);
293 X        $ret = fcntl($FH, ($lock & &LOCK_NB) ? &F_SETLK : &F_SETLKW, $flock);
294 X       return ($ret == -1 ? undef : 1);
295 X    }
296 }
297 SHAR_EOF
298   $shar_touch -am 1031100396 'mailprio' &&
299   chmod 0755 'mailprio' ||
300   echo 'restore of mailprio failed'
301   shar_count="`wc -c < 'mailprio'`"
302   test 8260 -eq "$shar_count" ||
303     echo "mailprio: original size 8260, current size $shar_count"
304 fi
305 # ============= mailprio.README ==============
306 if test -f 'mailprio.README' && test X"$1" != X"-c"; then
307   echo 'x - skipping mailprio.README (file already exists)'
308 else
309   echo 'x - extracting mailprio.README (text)'
310   sed 's/^X//' << 'SHAR_EOF' > 'mailprio.README' &&
311 mailprio README
312 X
313 mailprio.README,v 1.2 1996/10/31 17:03:54 sanders Exp
314 Version 0.93 -- Thu Oct 31 09:42:25 MST 1996
315 X
316 Copyright 1994, 1996, Tony Sanders <sanders@earth.com>
317 Rights are hereby granted to download, use, modify, sell, copy, and
318 redistribute this software so long as the original copyright notice
319 and this list of conditions remain intact and modified versions are
320 noted as such.
321 X
322 I would also very much appreciate it if you could send me a copy of
323 any changes you make so I can possibly integrate them into my version.
324 X
325 The current version of this and other related mail tools are available in:
326 X       ftp://ftp.earth.com/pub/postmaster/
327 X
328 Even with the new persistent host status in sendmail V8.8.X this
329 function can still reduce the lag time distributing mail to a large
330 group of people.  It also makes it a little more likely that everyone
331 will get mailing list mail in the order sent which can help reduce
332 duplicate postings.  Basically, the goal is to put slow hosts at
333 the bottom of the list so that as many fast hosts are delivered
334 as quickly as possible.
335 X
336 CONTENTS
337 ========
338 X
339 X    mailprio.README            -- simple docs
340 X    mailprio                   -- the address sorter
341 X    mailprio_mkdb              -- builds the database for the sorter
342 X
343 X
344 CHANGES
345 =======
346 X    Version 0.92
347 X       Initial public release.
348 X
349 X    Version 0.93
350 X       Updated to make use of the (somewhat) new xdelay statistic.
351 X       Changed -q flag to support new sendmail queue file format (RFD:<addr>).
352 X       Fixed argument parsing bug.
353 X       Fixed bug with database getting "garbage" in it.
354 X
355 X
356 CONFIGURATION
357 =============
358 X
359 X    You need to edit each script and ensure proper configuration.
360 X
361 X    In mailprio check:        #!perl path, $home, $priodb, $locking
362 X
363 X    In mailprio_mkdb check:   #!perl path, $home, $priodb, $maillog
364 X
365 X
366 USAGE: mailprio
367 ===============
368 X
369 X    Usage: mailprio [-p priodb] [-q] [mailinglists ...]
370 X       -p priority_database   -- Specify database to use if not default
371 X       -q                     -- Process sendmail queue format files
372 X                                 [USE WITH CAUTION]
373 X
374 X    Sort mailing lists or sendmail V8 queue files by mailprio database.
375 X    Files listed on the command line are locked and then sorted in place, in
376 X    the absence of any file arguments it will read STDIN and write STDOUT.
377 X
378 X    Examples:
379 X       mailprio < mailing-list > sorted_list
380 X       mailprio mailing-list1 mailing-list2 mailing-list3 ...
381 X       mailprio -q /var/spool/mqueue/qf*       [not recommended]
382 X    To double check results:
383 X       sort sorted_list > checkit; sort orig-mailing-list | diff - checkit
384 X
385 X    NOTE:
386 X       To get the maximum value from a transaction delay based priority
387 X       function you need to reorder the distribution list (and the mail
388 X       queue files for that matter) fairly often; you could even have
389 X       your mailing list software reorder the list before each outgoing
390 X       message.
391 X
392 X
393 USAGE: mailprio_mkdb
394 ====================
395 X
396 X    Usage: mailprio_mkdb [-l maillog] [-p priodb]
397 X       -l maillog             -- Specify maillog to process if not default
398 X       -p priority_database   -- Specify database to use if not default
399 X
400 X    Builds the mail priority database using information from the maillog.
401 X
402 X    Run at least nightly before you rotate the maillog.  If you are
403 X    going to run mailprio more often than that then you will need to
404 X    load the current maillog information before that will do any good
405 X    (and to keep from reloading the same information you will need
406 X    some kind of incremental maillog information to load from).
407 SHAR_EOF
408   $shar_touch -am 1031100396 'mailprio.README' &&
409   chmod 0644 'mailprio.README' ||
410   echo 'restore of mailprio.README failed'
411   shar_count="`wc -c < 'mailprio.README'`"
412   test 3402 -eq "$shar_count" ||
413     echo "mailprio.README: original size 3402, current size $shar_count"
414 fi
415 # ============= mailprio_mkdb ==============
416 if test -f 'mailprio_mkdb' && test X"$1" != X"-c"; then
417   echo 'x - skipping mailprio_mkdb (file already exists)'
418 else
419   echo 'x - extracting mailprio_mkdb (text)'
420   sed 's/^X//' << 'SHAR_EOF' > 'mailprio_mkdb' &&
421 #!/usr/bin/perl
422 #
423 # mailprio_mkdb,v 1.5 1996/10/31 17:03:53 sanders Exp
424 # Version 0.93 -- Thu Oct 31 09:42:25 MST 1996
425 #
426 # mailprio_mkdb -- make mail priority database based on delay times
427 #
428 # Copyright 1994, 1996, Tony Sanders <sanders@earth.com>
429 # Rights are hereby granted to download, use, modify, sell, copy, and
430 # redistribute this software so long as the original copyright notice 
431 # and this list of conditions remain intact and modified versions are
432 # noted as such.
433 #
434 # I would also very much appreciate it if you could send me a copy of
435 # any changes you make so I can possibly integrate them into my version.
436 #
437 # The average function moves the value around quite rapidly (half-steps)
438 # which may or may not be a feature.  This version uses the new xdelay
439 # statistic (new as of sendmail V8) which is per transaction.  We also
440 # weight the result based on the overall delay.
441 #
442 # Something that might be worth doing for systems that don't support
443 # xdelay would be to compute an approximation of the transaction delay
444 # by sorting by messages-id and delay then computing the difference
445 # between adjacent delay values.
446 #
447 # To get the maximum value from a transaction delay based priority
448 # function you need to reorder the distribution list (and the mail
449 # queue files for that matter) fairly often; you could even have
450 # your mailing list software reorder the list before each outgoing
451 # message.
452 X
453 $usage = "Usage: mailprio_mkdb [-l maillog] [-p priodb]\n";
454 $home = "/home/sanders/lists";
455 $maillog = "/var/log/maillog";
456 $priodb = "$home/mailprio";
457 X
458 while ($ARGV[0] =~ /^-/) {
459 X       $args = shift;
460 X       if ($args =~ m/\?/) { print $usage; exit 0; }
461 X       if ($args =~ m/l/) {
462 X           $maillog = shift || die $usage, "-l requires argument\n"; }
463 X       if ($args =~ m/p/) {
464 X           $priodb = shift || die $usage, "-p requires argument\n"; }
465 }
466 X
467 $SIG{'PIPE'} = 'handle_pipe';
468 X
469 # will merge with existing information
470 dbmopen(%prio, $priodb, 0644) || die "$priodb: $!\n";
471 &getlog_stats($maillog, *prio);
472 dbmclose(%prio);
473 exit(0);
474 X
475 sub handle_pipe {
476 X    dbmclose(%prio);
477 }
478 X
479 sub getlog_stats {
480 X    local($maillog, *stats) = @_;
481 X    local($to, $delay);
482 X    local($h, $m, $s);
483 X    open(MAILLOG, "< $maillog") || die "$maillog: $!\n";
484 X    while (<MAILLOG>) {
485 X       next unless / to=/ && / stat=/;
486 X       next if / stat=queued/;
487 X       if (/ stat=sent/i) {
488 X           # read delay and xdelay and convert to seconds
489 X           ($delay) = (m/ delay=([^,]*),/);
490 X           next unless $delay;
491 X           ($h, $m, $s) = split(/:/, $delay);
492 X           $delay = ($h * 60 * 60) + ($m * 60) + $s;
493 X
494 X           ($xdelay) = (m/ xdelay=([^,]*),/);
495 X           next unless $xdelay;
496 X           ($h, $m, $s) = split(/:/, $xdelay);
497 X           $xdelay = ($h * 60 * 60) + ($m * 60) + $s;
498 X
499 X           # Now weight the delay factor by the transaction delay (xdelay).
500 X           $xdelay /= 300;                     # [0 - 1(@5 min)]
501 X           $xdelay += 0.5;                     # [0.5 - 1.5]
502 X           $xdelay = 1.5 if $xdelay > 1.5;     # clamp
503 X           $delay *= $xdelay;                  # weight delay by xdelay
504 X       }
505 X       elsif (/, stat=/) {
506 X           # delivery failure of some sort (i.e. bad)
507 X           $delay = 432000;            # force 5 days
508 X       }
509 X       $delay = 1000000 if $delay > 1000000;
510 X
511 X       # filter the address(es); isn't perfect but is "good enough"
512 X       $to = $_; $to =~ s/^.* to=//;
513 X       1 while $to =~ s/\([^\(\)]*\)//g;       # strip comments
514 X       1 while $to =~ s/"[^"]*"//g;            # strip comments
515 X       $to =~ s/, .*//;                        # remove other stat info
516 X       foreach $addr (&simplify_address($to)) {
517 X           next unless $addr;
518 X           $addr = &canonicalize($addr);
519 X           $stats{$addr} = $delay unless defined $stats{$addr};        # init
520 X           # pseudo-average in the new delay (half-steps)
521 X           # simple, moving average
522 X           $stats{$addr} = int(($stats{$addr} + $delay) / 2);
523 X       }
524 X    }
525 X    close(MAILLOG);
526 }
527 X
528 # REPL-LIB ---------------------------------------------------------------
529 X
530 sub canonicalize {
531 X    local($addr) = @_;
532 X    # lowercase, strip leading/trailing whitespace
533 X    $addr =~ y/A-Z/a-z/; $addr =~ s/^\s+//; $addr =~ s/\s+$//; $addr;
534 }
535 X
536 # @addrs = simplify_address($addr);
537 sub simplify_address {
538 X    local($_) = shift;
539 X    1 while s/\([^\(\)]*\)//g;                 # strip comments
540 X    1 while s/"[^"]*"//g;              # strip comments
541 X    split(/,/);                                # split into parts
542 X    foreach (@_) {
543 X       1 while s/.*<(.*)>.*/\1/;
544 X       s/^\s+//;
545 X       s/\s+$//;
546 X    }
547 X    @_;
548 }
549 SHAR_EOF
550   $shar_touch -am 1031100396 'mailprio_mkdb' &&
551   chmod 0755 'mailprio_mkdb' ||
552   echo 'restore of mailprio_mkdb failed'
553   shar_count="`wc -c < 'mailprio_mkdb'`"
554   test 4182 -eq "$shar_count" ||
555     echo "mailprio_mkdb: original size 4182, current size $shar_count"
556 fi
557 exit 0