#! /usr/local/bin/perl5 -w

# Jason's SQL modifications for a postfix greylisting policy server
# Based on multiple sources, and ripped down to bare bones after that

# GPL'd due to prior work incorporated into this being GPL'd

# Based in part on:
# From  http://gigo.com/src.html - * Greylisting daemon for Postfix (MySQL based)
# http://gigo.com/ftp/pub/src/greylist.pl
# Previously released without specific license
# based on Weitse's sample policy server for DBM
# Based in part on:
# From http://isg.ee.ethz.ch/tools/postgrey/
# postgrey: a postfix greylisting policy server
# Copyright 2004 (c) ETH Zurich
# released under the GNU General Public License

# see the documentation with 'perldoc postgreysql'

package postgreysql;
use strict;
use Pod::Usage;
use DBI;
use DBD::SQLite;
use Getopt::Long 2.25 qw(:config posix_default no_ignore_case);
use Data::Dumper;
use Net::Server::Multiplex;
use YAML::Syck;
use Net::IP;
use Digest::MD5 qw(md5_base64);


use vars qw(@ISA);
@ISA = qw(Net::Server::Multiplex);

my  %lists   = (
  'crpl@corvette-resto.com' => 'crpl',
  'bsdnet@bsdnet.org' => 'bsdnet',
  'bsdnet-ops@bsdnet.org' => 'bsdnet-ops',
  'users@lists.roundcube.net' => 'users',
  'dev@lists.roundcube.net' => 'dev',
  'svn@lists.roundcube.net' => 'svn',
  'notify@lists.roundcube.net' => 'notify',
  'announce@lists.roundcube.net' => 'announce',
  'woodworkers@sawdusters.org' => 'woodworkers',
  'notsand@bsdnet.org' => 'notsand',
  'v6p@test-ipv6.com' => 'v6providers',
  'v6providers@test-ipv6.com' => 'v6providers',
);

foreach my $key (keys %lists) {
  my $value = $lists{$key};
  my($listid,$domain) = split(/\@/,$key);
  $lists{"$listid\@gigo.com"}=$value;
  $lists{"$listid\@lists.gigo.com"}=$value;
}


my $VERSION = '0.9';

my @program = `cat $0 2>&1`;    # Self referencing

# Usage:  breakpoint()  will automatically run a break, if and only if you're in the perl debugger
sub breakpoint {
    $DB::single = 2;
    $DB::single = 2;    # Avoid warnings by setting it twice, yay perl -w
}

sub do_maintenance($$) {
    my ( $self, $now ) = @_;
print STDERR "Doing maintenance on database\n";
    my $deadline = time - $self->{policy}{max_age};
    my $dbh      = $self->{policy}{db};
    my $SQL      = <<'EOF';
delete from entities where updatedate-insertdate < 300  and updatedate < $deadline
EOF

    $dbh->do($SQL);
print STDERR "  .. Compacting database\n";

   $SQL = "vacuum";
    $dbh->do($SQL);
print STDERR "  .. done\n";

} ## end sub do_maintenance($$)

# main routine: based on attributes specified as argument, return policy decision
sub smtpd_access_policy($$) {

    die unless (@_);
    my ( $self, $attr ) = @_;
    my $dbh = $self->{policy}{db};
    my $now = time();

    breakpoint();


  ######################################################
  # MAILING LISTS                                      #
  ######################################################

   ${$attr}{"orig-sender"} = ${$attr}{"sender"};

   my $r = lc ${$attr}{"recipient"};
   $r =~ s/\@(.*)\.gigo\.com$/\@gigo.com/;  # Normalize
   my $s = lc ${$attr}{"sender"};
      $s ||= "NOT SPECIFIED";
   my $u = "http://archives.gigo.com";   
      $u = "http://lists.roundcube.net" if ($r =~ m/roundcube/);
   my $isalist =  exists $lists{$r};

    breakpoint();


  ######################################################
  # MAINTENANCE                                        #
  ######################################################
    # do maintenance if one hour has passed since the last one
    if ( $now - $self->{policy}{last_maint} > 3600 ) {
        $self->{policy}{last_maint} = $now;
        $self->do_maintenance($now);
    }

    ######################################################################
    # Ugly section.  Lots of thins I want to apply to just the greylist  #
    # and not filtering in general on postfix.  Also, due to where *I*   #
    # run the greylist, I want the greylist to be authoritive on denial, #
    # unauthoritive on permission.                                       #
    ######################################################################

    my $bypass = 0;


    # quick disabler - still logs to SQL tho
    # Only trust if it is < 1H old
    if ( -f "/tmp/bypass" ) {
        if ( ( time - ( stat("/tmp/bypass") )[9] ) < 3600 ) {
            $bypass = __LINE__ if ( -f "/tmp/bypass" );
        }
    }

$bypass = __LINE__ if (${$attr}{recipient} =~ /notsand/);


    $bypass = __LINE__
      if (    ( ${$attr}{"recipient"} =~ m/dsuchter/ )
           && ( ${$attr}{"sender"} =~ m/ucla/i ) );

    $bypass = __LINE__ if ( ${$attr}{"client_name"} =~ m/paypal/ );
    $bypass = __LINE__ if ( ${$attr}{"sender"}      =~ m/paypal/ );

    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/pager/ );
    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/mobile/ );

    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m/confirm/i );

    $bypass = __LINE__
      if ( ${$attr}{"recipient"} =~ m/web.*\@kissmygrass.com/i );

    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/ibrown/ );
    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/kaboing/ );
    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/hcarney/i );

   $bypass = __LINE__ if (${$attr}{"recipient"} =~ m/personalsecurityzone/i);



    # postmasters are required to get mail.
    if ( ${$attr}{"recipient"} =~ m/postmaster/i ) {
     print STDERR  "postmaster!    s=$s\n";
     return "550 Rejecting spam bounces back to forged postmaster address" if ($s =~ /NOT SPECIFIED/);
     return "dunno";
    }
    # Treat postmaster special.  Some day I'll regret this I'm sure.
    $bypass = __LINE__ if ( ${$attr}{"sender"}    =~ m/^postmaster\@/i );

$bypass = __LINE__ if ((${$attr}{"recipient"} =~ /bwoodwebmin/) &&
(${$attr}{"client_name"} =~ /dreamhost/));

    # Exim's equivalent of sender verification
    $bypass = __LINE__
      if ( ${$attr}{"recipient"} =~ m/${$attr}{client_name}-.*-testing\@/ );

    # Specific ugly formats that don't suit greylisting at all.
    # Note that groups.yahoo.com treats 451 (TEMPFAIL) as *PERMANENT*.  :(
    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m#returns.groups.yahoo.com# );
    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m#returns.bulk.yahoo.com# );
    $bypass = __LINE__
      if ( ${$attr}{"sender"} =~ m#.*-.*=.*\..*@.*# )
      ;    # VERP? not seen with spam really

    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m#google# );

    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m#[.\@]ups.com$#i );

    # more sites that treat 450 as 550:
    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m#registeredsite.com$# );
    $bypass = __LINE__ if ( ${$attr}{"sender"} =~ m#he.net$# );

    # "fix" sender addresses to strip out numbers that are used for tracking
    ${$attr}{"sender"} =~ s/(?=.*@)\b\d+\b/-#-#/g
      ; #  from=<rangers-allcom-list-return-4381-user=domain.com@burningman.com>

    # ebay is really slow to resend mail - as much as 2-3 hours!
    $bypass = __LINE__
      if (    ( ${$attr}{"sender"} =~ m/[@.](ebay.com|ebaymails.com)$/ )
           && ( ${$attr}{"client_name"} =~ m/[@.](ebay.com|ebaymails.com)$/ ) );

    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/ebay\@/ );
    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/\+ebay/ );

    # I don't want locally generated mail to be slowed down.
    $bypass = __LINE__ if ( ${$attr}{"client_address"} eq "127.0.0.1" );
    $bypass = __LINE__ if ( ${$attr}{"client_address"} eq "64.57.102.22" );


    # Some mailing lists suck and don't reset the Sender: address
    # to a list owner.    This one is for Jeff.
    $bypass = __LINE__ if ( ${$attr}{"client_name"} =~ m/laughingsquid.net$/ );

    # Bounces are either legit - or user unknown.  Let'em in quick.
    $bypass = __LINE__ if ( ${$attr}{"recipient"} =~ m/bounces/i );

    # johnk
#    return "dunno" if ( ${$attr}{"recipient"} =~ m/hypergeek.net/i );





if ($bypass) {
#  return "451 bypass=$bypass";
}
    # Find out when we first got mail from this IP/sender/recipient
    # This also updates the mysql database as a side effect

  ######################################################
  # SPECIAL HANDLING FOR MX2                           #
  ######################################################
    
   ${$attr}{"var_smtpd_banner"}  ||= "";

    if (${$attr}{"var_smtpd_banner"} =~ m/second/) {
        my ($time_stamp) = read_database( $self, $attr, 1); #READONLY
        if ($time_stamp) {
            ${$attr}{"lastaction"} =
              "mx2 saw previous greylist entry, had to be frmo primary mx, will allow this connection";
            return "OK";
        } else {
            ${$attr}{"lastaction"} = "mx2 no previous greylist entry, tempfail";
            return "451 temp fail; retry primary mx; code 2";
        }
    } 

  ######################################################
  # Check the greylist                                 #
  ######################################################
    my ($time_stamp) = read_database( $self, $attr, 0 );
    my ($age) = time() - $time_stamp;


  ######################################################
  #   DECISION TIME                                    #
  ######################################################

    if ($bypass && !$isalist) {
        ${$attr}{"lastaction"} =
          "bypassed by $0 line $bypass : " . $program[ $bypass - 1 ];
        return "dunno";
    }


  ######################################################
  # HELO CHECKS                                        #
  ######################################################

    # We previously bypassed if the *IP* address was us
    # Nobody else should claim to be us.
    if (    ( ${$attr}{"helo_name"} eq "64.57.102.22" )
         || ( ${$attr}{"helo_name"} eq "gigo.com" )
         || ( ${$attr}{"helo_name"} eq "mx2.gigo.com" )
         || ( ${$attr}{"helo_name"} eq "vette.gigo.com" )
         || ( ${$attr}{"helo_name"} eq "heaven.gigo.com" ) )
    {
        ${$attr}{"lastaction"} = "550 You are not really ${$attr}{helo_name}.";
        return ${$attr}{"lastaction"};
    } ## end if ( ( ${$attr}{"helo_name"...


  ######################################################
  # MAILING LISTS                                      #
  ######################################################

   if ($isalist) {
my $sender = lc ${$attr}{"orig-sender"};
     my $want=0;
#return "451 System upgrade in process, mailing lists not read to go live";
#return "451 dunno r=$r lists{r}=$lists{$r}";
     my $list = "/etc/postfix/tables/list.$lists{$r}";

     open(LIST,"<$list") or return "450 Unable to open $list, try again in a few";
     while(<LIST>) {
       chomp; 
       $_ = lc $_;
       $want++ if ($sender eq $_);
     }
     close LIST;
     if ($want) {
       return "dunno";
     } else {
       if (($time_stamp) && ( $age > $self->{policy}{delay} )) { 
         # Passed the greylist - lets refuse the mail
         return "550 Please wait 5 minutes after you subscribe to $r before attempting to post; or subscribe/resubscribe at $u";
       } else { 
         # Did not pass the greylist - lets TEMPFAIL this 
         # And perhaps when they retry, the sender will be 
         # listed as a subscriber
         return "450 Please wait 5 minutes after you subscribe to $r before attempting to post; or subscribe/resubscribe at $u";
       }
     } 
   }
  # Done testing mailing lists



    if ( $time_stamp == 0 ) {
        ${$attr}{"lastaction"} =
          "dunno - WARNING we got back '0' from read_database";
        warn "WARNING: got back '0' from read_database\n";
        return "dunno";
    } ## end if ( $time_stamp == 0 )

    # Specify DUNNO instead of OK so that the check_policy_service restriction
    # can be followed by other restrictions.
    if ( $age > $self->{policy}{delay} ) {
        ${$attr}{"lastaction"} = "passed greylist, first saw $age seconds ago";
        return "dunno";
    } else {
        my $diff = $self->{policy}{delay} - $age;
        my $minutes = sprintf( "%0.1f", ( $diff / 60 ) + .049 );
        my $md5 = md5_base64(rand(1) . $diff);
        $md5 =~ s/^[a-z0-9]//g;
        $md5 = substr($md5,0,6);
        ${$attr}{"lastaction"} =
          "450 Service is unavailable; code $diff; try again in $minutes minutes; id=$md5";
        return ${$attr}{"lastaction"};
    } ## end else [ if ( $age > $self->{policy...

    ${$attr}{"lastaction"} = "unexpectedly hit line " . __LINE__;
    return 'dunno';
} ## end sub smtpd_access_policy($$)

#
# Read database. Use a shared lock to avoid reading the database
# while it is being changed.
#
sub read_database {
    my ( $self, $attr, $ro ) = @_;
    $ro ||= 0;
    my $dbh = $self->{policy}{db};
    die "dbh not defined" unless ($dbh);
    my ( $sth_update, $sth_lookup, $sth_insert, $sth_update2 );
    
   my $ipobject =  new Net::IP( ${$attr}{"client_address"});
   if ( $ipobject && Net::IP::ip_is_ipv6($ipobject)) {
     my(@parts) = split(/:/,$ipobject->ip);
     pop @parts;  # Round  /128 -> /112
     pop @parts;  # Round  /112 -> /96
     pop @parts;  # Round  /96 -> /80
     ${$attr}{"client_subnet"} = join(":",@parts) . ":";
   } else {
     ${$attr}{"client_subnet"} =  ${$attr}{"client_address"};
     ${$attr}{"client_subnet"} =~ s/\d+$/X/;
   }


    $sth_update ||=
      $dbh->prepare(
        "UPDATE entities SET counter=counter+1, updatedate=now(), insertdate=insertdate, client_name=?, helo_name=?, queue_id=?"
          . " WHERE client_address=? AND  sender=? AND recipient=?" );
    unless ($ro) {

        my $rv_update =
          $sth_update->execute(
                                ${$attr}{"client_name"},
                                ${$attr}{"helo_name"},
                                ${$attr}{"queue_id"},
                                ${$attr}{"client_subnet"},
                                ${$attr}{"sender"},
                                ${$attr}{"recipient"}
                              );

        if ( $rv_update < 1 ) {

            # Hm.  Maybe we should try inserting!
            $sth_insert ||=
              $dbh->prepare(
                "INSERT INTO entities(client_address,sender,recipient,client_name,helo_name,queue_id,updatedate,insertdate,counter) VALUES (?,?,?,?,?,?,now(),now(),1)"
              );
            my $rv_insert =
              $sth_insert->execute(
                                    ${$attr}{"client_subnet"},
                                    ${$attr}{"sender"},
                                    ${$attr}{"recipient"},
                                    ${$attr}{"client_name"},
                                    ${$attr}{"helo_name"},
                                    ${$attr}{"queue_id"}
                                  );
        } ## end if ( $rv_update < 1 )
    } ## end unless ($ro)

    $sth_lookup ||=
      $dbh->prepare( "SELECT insertdate,updatedate,seconddate, counter"
          . " FROM entities WHERE client_address=? AND sender=? AND recipient=?"
      );
    my $rv_lookup = $sth_lookup->execute( ${$attr}{"client_subnet"},
                                          ${$attr}{"sender"},
                                          ${$attr}{"recipient"} );
    my $hashref = $sth_lookup->fetchrow_hashref;

    return 0 if ( !defined $hashref );

    #  Even if we ARE mx2 .. go ahead and do this.
    if ( ${$hashref}{"counter"} == 2 ) {
        $sth_update2 ||=
          $dbh->prepare(
            "UPDATE entities SET seconddate=now(), insertdate=insertdate,updatedate=updatedate"
              . " WHERE client_address=? AND  sender=? AND recipient=?" );
        my $rv_update2 =
          $sth_update2->execute(
                                 ${$attr}{"client_subnet"},
                                 ${$attr}{"sender"},
                                 ${$attr}{"recipient"}
                               );
    } ## end if ( ${$hashref}{"counter"...

    return ( ${$hashref}{"insertdate"} );
} ## end sub read_database

sub main() {

    # save arguments for Net:Server HUP restart
    my @ARGV_saved = @ARGV;

    # parse options
    my %opt = ();
    GetOptions(
                \%opt,                  'help|h',
                'man',                  'version',
                'noaction|no-action|n', 'verbose|v',
                'daemonize|d',          'unix|u=s',
                'inet|i=s',             'user=s',
                'dbfile=s',             'delay=i',
                'max-age=i'
              ) or exit(1);
    if ( $opt{help} ) { pod2usage(1) }
    if ( $opt{man} ) { pod2usage( -exitstatus => 0, -verbose => 2 ) }
    if ( $opt{version} ) { print "postgreysql $VERSION\n"; exit(0) }
    if ( $opt{noaction} ) { die "ERROR: don't know how to \"no-action\".\n" }

    defined $opt{unix}
      or defined $opt{inet}
      or die "ERROR: --unix or --inet must be specified\n";

    # bind only localhost if no host is specified
    if ( defined $opt{inet} and $opt{inet} =~ /^\d+$/ ) {
        $opt{inet} = "localhost:$opt{inet}";
    }

    # create Net::Server object and run it
    my $server = bless {
                         server => {
                             commandline => [ $0, @ARGV_saved ],
                             port => [ $opt{inet} ? $opt{inet} : $opt{unix} ],
                             proto  => $opt{inet}      ? 'tcp' : 'unix',
                             setsid => $opt{daemonize} ? 1     : undef,
                                   },
                         policy => {
                                     delay  => $opt{delay}  || 600,
                                     dbfile => $opt{dbfile} || "$0.db.sqlite",
                                     max_age => $opt{'max-age'} || 1,
                                     last_maint => 0,
                                   },
                       },
      'postgreysql';

    # max_age is in days
    $server->{policy}{max_age} *= 3600 * 24;

    $server->run;
} ## end sub main()

##### Net::Server::Multiplex methods:

sub pre_loop_hook() {
    my ($self) = @_;

    # write files with mode 600
    umask 0077;

    # Start the database
    $self->{policy}{db} = start_database( $self->{policy}{dbfile} );
} ## end sub pre_loop_hook()

sub mux_input() {
    my ( $self, $mux, $fh, $in_ref ) = @_;
    defined $self->{postgreysql_attr} or $self->{postgreysql_attr} = {};
    my $attr = $self->{postgreysql_attr};

    # consume entire lines
    while ( $$in_ref =~ s/^([^\n]*)\n// ) {
        next unless defined $1;
        my $in = $1;
        if ( $in =~ /([^=]+)=(.*)/ ) {

            # read attributes
            $attr->{ substr( $1, 0, 512 ) } = substr( $2, 0, 512 );
        } elsif ( $in eq '' ) {
            defined $attr->{request} or $attr->{request} = '';
            if ( $attr->{request} ne 'smtpd_access_policy' ) {
                print STDERR "unrecognized request type: '$attr->{request}'\n";
            } else {
                my $action = $self->{net_server}->smtpd_access_policy($attr);
                print $fh "action=$action\n\n";
                local $Data::Dumper::Sortkeys = 1;
my %x = %{$attr};
foreach (keys %x) {
 delete $x{$_} unless ($x{$_});
};
print STDERR Dump(\%x);
                print STDERR "action: $action\n\n";
            } ## end else [ if ( $attr->{request} ...
            $self->{postgreysql_attr} = {};
        } else {
            print STDERR "ignoring garbage: <" . substr( $in, 0, 100 ) . ">\n";
        }
    } ## end while ( $$in_ref =~ s/^([^\n]*)\n//)
} ## end sub mux_input()

sub start_database {
    my ($dbname) = @_;
    my ( $dbh, $sth, $rv );
    my (@DBIPARMS) = ( "DBI:SQLite:dbname=$dbname", '', '' );
    $dbh = DBI->connect(@DBIPARMS);
    unless ($dbh) {
        die("Unable to connect to DBI: @DBIPARMS\n");
    }

    my $SQL_CREATE = <<'EOF';

   CREATE TABLE entities (
    id  INTEGER PRIMARY KEY,
    client_address text,
    sender text,
    recipient text,
    client_name text,
    helo_name text,
    queue_id text,
    insertdate text,
    seconddate text,
    updatedate text,
    counter integer);

  create        index  idx_client_address on entities (client_address);
  create        index  idx_sender on entities (sender);
  create        index  idx_recipient on entities (recipient);
  create unique index  idx_csr on entities (client_address,sender,recipient);

EOF

    my @existing_table =
      $dbh->selectrow_array(
                      "select name from sqlite_master where name = 'entities'");
    unless ( scalar @existing_table ) {
        $rv = $dbh->do($SQL_CREATE);
        unless ( defined $rv ) {
            my $e = $dbh->errstr;
            die
              "Failed to create table in database: $e\nFailed on SQL:\n$SQL_CREATE\n";
        }
    } ## end unless ( scalar @existing_table)

    $dbh->func( 'now', 0, sub { return time }, 'create_function' );

    return $dbh;
} ## end sub start_database

main;

__END__

=head1 NAME

postgreysql - Postfix Greylist Policy Server

=head1 SYNOPSIS

B<postgreysql> [I<options>...]

 -h, --help             display this help and exit
     --version          output version information and exit
 -v, --verbose          increase verbosity level

 -u, --unix=PATH        listen on unix socket PATH
 -i, --inet=[HOST:]PORT listen on PORT, localhost if HOST is not specified
 -d, --daemonize        run in the background
     --user=USER        run as USER (default: postgreysql)
     --dbfile=PATH       put db files in PATH (default: /var/spool/postfix/postgreysql)
     --delay=N          greylist for N seconds (default: 600)
     --max-age=N        delete entries older than N days since the last time
                        that they have been seen (default: 14)

=head1 DESCRIPTION

Postgrey is a Postfix policy server implementing greylisting.

When a request for delivery of a mail is received by Postfix via SMTP, the
triplet C<CLIENT_IP> / C<SENDER> / C<RECIPIENT> is built. If it is the first
time that this triplet is seen, or if the triplet was first seen less than
I<delay> seconds (600 is the default), then the mail gets rejected with a
temporary error. Hopefully spammers or viruses will not try again later, as it
is however required per RFC.

=head2 Installation

=over 4

=item *

Create a C<postgreysql> user and the directory where to put the database I<dbfile>
(default: C</var/spool/postfix/postgreysql>)

=item *

Write an init script to start postgreysql at boot and start it. Like this for example:

 postgreysql --inet=10023 -d

Personally, I use daemontools, but that's a choice I made.

=item *

Put something like this in /etc/main.cf:

 smtpd_recipient_restrictions =
               ...
               reject_unauth_destination
               check_client_access    hash:/etc/postfix/postgreysql_client_access
               check_recipient_access hash:/etc/postfix/postgreysql_recipient_access
               check_policy_service inet:127.0.0.1:10023

=item *

Install the provided postgreysql_client_access in /etc/postfix and postmap it.
Some servers do not behave correctly and do not resend mails (as required in
the standard) or use complicated unique return addresses.

=item *

Put in /etc/postfix/postgreysql_recipient_access users that do not want greylisting
like this:

  i_like_spam@ee.ethz.ch                OK

=back

=head2 SEE ALSO

See L<http://www.greylisting.org/> for a description of what greylisting is
and L<http://www.postfix.org/SMTPD_POLICY_README.html> for a description of how
Postfix policy servers work.

=head1 COPYRIGHT

Copyright (c) 2004 by ETH Zurich. All rights reserved.

=head1 LICENSE

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., 675 Mass Ave, Cambridge, MA 02139, USA.

=head1 AUTHOR

S<David Schweikert E<lt>dws@ee.ethz.chE<gt>>

=head1 HISTORY

 2004-05-20 ds Initial Version

=cut