+++ /dev/null
-#!/usr/bin/perl
-#################################################################################
-#
-# File: $RCSfile: MAPS.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: Main module for Mail Authentication and Permission System (MAPS)
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPS;
-
-use strict;
-
-use FindBin;
-
-use MAPSDB;
-use MAPSLog;
-use MAPSFile;
-use MAPSUtil;
-use MIME::Entity;
-
-use vars qw (@ISA @EXPORT);
-use Exporter;
-
-@ISA = qw (Exporter);
-
-@EXPORT = qw (
- Add2Blacklist
- Add2Nulllist
- Add2Whitelist
- AddEmail
- AddList
- AddUser
- AddUserOptions
- Blacklist
- CleanEmail
- CleanLog
- CleanList
- CountMsg
- Decrypt
- DeleteEmail
- DeleteList
- DeleteLog
- Encrypt
- FindEmail
- FindList
- FindLog
- FindUser
- ForwardMsg
- GetContext
- GetEmail
- GetList
- GetLog
- GetUser
- GetUserOptions
- ListLog
- ListUsers
- Login
- Nulllist
- OnBlacklist
- OnNulllist
- OnWhitelist
- OptimizeDB
- ReadMsg
- ResequenceList
- ReturnList
- ReturnListEntry
- ReturnMsg
- ReturnMessages
- ReturnSenders
- SaveMsg
- SearchEmails
- SetContext
- Space
- UpdateList
- UpdateUser
- UpdateUserOptions
- UserExists
- Whitelist
-);
-
-my $mapsbase = "$FindBin::Bin/..";
-
-# Forwards
-sub Add2Blacklist;
-sub Add2Nulllist;
-sub Add2Whitelist;
-sub AddEmail;
-sub AddList;
-sub AddUser;
-sub AddUserOptions;
-sub Blacklist;
-sub CleanEmail;
-sub CleanLog;
-sub CountMsg;
-sub Decrypt;
-sub DeleteEmail;
-sub DeleteList;
-sub DeleteLog;
-sub Encrypt;
-sub FindEmail;
-sub FindList;
-sub FindLog;
-sub FindUser;
-sub ForwardMsg;
-sub GetContext;
-sub GetEmail;
-sub GetList;
-sub GetLog;
-sub GetUser;
-sub GetUserOptions;
-sub Login;
-sub Nulllist;
-sub OnBlacklist;
-sub OnNulllist;
-sub OnWhitelist;
-sub OptimizeDB;
-sub ReadMsg;
-sub ResequenceList;
-sub ReturnList;
-sub ReturnListEntry;
-sub ReturnMsg;
-sub ReturnMessages;
-sub ReturnSenders;
-sub SaveMsg;
-sub SearchEmails;
-sub SendMsg;
-sub SetContext;
-sub Space;
-sub UpdateList;
-sub UpdateUser;
-sub UpdateUserOptions;
-sub UserExists;
-sub Whitelist;
-
-BEGIN {
- my $MAPS_username = "maps";
- my $MAPS_password = "spam";
-
- OpenDB $MAPS_username, $MAPS_password;
-} # BEGIN
-
-END {
- CloseDB;
-} # END
-
-sub Add2Blacklist {
- # Add2Blacklist will add an entry to the blacklist
- my ($sender, $userid, $comment) = @_;
-
- # First SetContext to the userid whose black list we are adding to
- MAPSDB::SetContext $userid;
-
- # Add to black list
- AddList "black", $sender, 0, $comment;
-
- # Log that we black listed the sender
- Info "Added $sender to " . ucfirst $userid . "'s black list";
-
- # Delete old emails
- my $count = DeleteEmail $sender;
-
- # Log out many emails we managed to remove
- Info "Removed $count emails from $sender"
-} # Add2Blacklist
-
-sub Add2Nulllist ($$;$$) {
- # Add2Nulllist will add an entry to the nulllist
- my ($sender, $userid, $comment, $hit_count) = @_;
-
- # First SetContext to the userid whose null list we are adding to
- MAPSDB::SetContext $userid;
-
- # Add to null list
- AddList "null", $sender, 0, $comment, $hit_count;
-
- # Log that we null listed the sender
- Info "Added $sender to " . ucfirst $userid . "'s null list";
-
- # Delete old emails
- my $count = DeleteEmail $sender;
-
- # Log out many emails we managed to remove
- Info "Removed $count emails from $sender"
-} # Add2Nulllist
-
-sub Add2Whitelist ($$;$) {
- # Add2Whitelist will add an entry to the whitelist
- my ($sender, $userid, $comment) = @_;
-
- # First SetContext to the userid whose white list we are adding to
- MAPSDB::SetContext $userid;
-
- # Add to white list
- AddList 'white', $sender, 0, $comment;
-
- # Log that we registered a user
- Logmsg "registered", $sender, "Registered new sender";
-
- # Check to see if there are any old messages to deliver
- my $handle = FindEmail $sender;
-
- my ($dbsender, $subject, $timestamp, $message);
-
- # Deliver old emails
- my $messages = 0;
- my $return_status = 0;
-
- while (($userid, $dbsender, $subject, $timestamp, $message) = GetEmail $handle) {
- last
- unless $userid;
-
- $return_status = Whitelist $sender, $message;
-
- last
- if $return_status;
-
- $messages++;
- } # while
-
- # Done with $handle
- $handle->finish;
-
- # Return if we has a problem delivering email
- return $return_status
- if $return_status;
-
- # Remove delivered messages.
- DeleteEmail $sender;
-
- return $messages;
-} # Add2Whitelist
-
-sub AddEmail ($$$) {
- my ($sender, $subject, $data) = @_;
-
- MAPSDB::AddEmail $sender, $subject, $data;
-} # AddEmail
-
-sub AddList ($$$;$$$) {
- my ($listtype, $pattern, $sequence, $comment, $hit_count, $last_hit) = @_;
-
- $hit_count //= CountMsg $pattern;
-
- MAPSDB::AddList $listtype, $pattern, $sequence, $comment, $hit_count, $last_hit;
-} # AddList
-
-sub AddUser ($$$$) {
- my ($userid, $realname, $email, $password) = @_;
-
- return MAPSDB::AddUser $userid, $realname, $email, $password;
-} # AddUser
-
-sub AddUserOptions ($%) {
- my ($userid, %options) = @_;
-
- my $status;
-
- foreach (keys (%options)) {
- $status = MAPSDB::AddUserOption $userid, $_, $options{$_};
- last if $status ne 0;
- } # foreach
-
- return $status;
-} # AddUserOptions
-
-sub Blacklist ($$$@) {
- # Blacklist will send a message back to the $sender telling them that
- # they've been blacklisted. Currently we save a copy of the message.
- # In the future we should just disregard the message.
- my ($sender, $sequence, $hit_count, @msg) = @_;
-
- # Check to see if this sender has already emailed us.
- my $msg_count = CountMsg $sender;
-
- if ($msg_count lt 5) {
- # Bounce email
- SendMsg ($sender, "Your email has been discarded by MAPS", "$mapsbase/blacklist.html", @msg);
- Logmsg "blacklist", $sender, "Sent blacklist reply";
- } else {
- Logmsg "mailloop", $sender, "Mail loop encountered";
- } # if
-
- RecordHit "black", $sequence, ++$hit_count if $sequence;
-} # Blacklist
-
-sub CleanEmail ($) {
- my ($timestamp) = @_;
-
- MAPSDB::CleanEmail $timestamp;
-} # CleanEmail
-
-sub CleanLog ($) {
- my ($timestamp) = @_;
-
- MAPSDB::CleanLog $timestamp;
-} # CleanLog
-
-sub CleanList ($;$) {
- my ($timestamp, $listtype) = @_;
-
- MAPSDB::CleanList $timestamp, $listtype;
-} # CleanList
-
-sub CountMsg ($) {
- my ($sender) = @_;
-
- return MAPSDB::CountMsg $sender;
-} # CountMsg
-
-sub Decrypt ($$) {
- my ($password, $userid) = @_;
-
- return MAPSDB::Decrypt $password, shift;
-} # Decrypt
-
-sub DeleteEmail ($) {
- my ($sender) = @_;
-
- return MAPSDB::DeleteEmail $sender;
-} # DeleteEmail
-
-sub DeleteList ($$) {
- my ($type, $sequence) = @_;
-
- return MAPSDB::DeleteList $type, $sequence;
-} # DeleteList
-
-sub DeleteLog ($) {
- my ($sender) = @_;
-
- return MAPSDB::DeleteLog $sender;
-} # DeleteLog
-
-sub Encrypt ($$) {
- my ($password, $userid) = @_;
-
- return MAPSDB::Encrypt $password, $userid;
-} # Encrypt
-
-sub FindEmail (;$) {
- my ($sender) = @_;
-
- return MAPSDB::FindEmail $sender;
-} # FindEmail
-
-sub FindList ($;$) {
- my ($type, $sender) = @_;
-
- return MAPSDB::FindList $type, $sender;
-} # FindList
-
-sub FindLog ($) {
- my ($how_many) = @_;
-
- my $start_at = 0;
- my $end_at = MAPSDB::countlog ();
-
- if ($how_many < 0) {
- $start_at = $end_at - abs ($how_many);
- $start_at = 0 if ($start_at < 0);
- } # if
-
- return MAPSDB::FindLog $start_at, $end_at;
-} # FindLog
-
-sub FindUser (;$) {
- my ($userid) = @_;
-
- return MAPSDB::FindUser $userid
-} # FindUser
-
-sub GetContext () {
- return MAPSDB::GetContext ();
-} # GetContext
-
-sub GetEmail ($) {
- my ($handle) = @_;
-
- return MAPSDB::GetEmail $handle;
-} # GetEmail
-
-sub GetList ($) {
- my ($handle) = @_;
-
- return MAPSDB::GetList $handle;
-} # GetList
-
-sub GetLog ($) {
- my ($handle) = @_;
-
- return MAPSDB::GetLog $handle;
-} # GetLog
-
-sub GetUser ($) {
- my ($handle) = @_;
-
- return MAPSDB::GetUser $handle;
-} # GetUser
-
-sub GetUserOptions ($) {
- my ($userid) = @_;
-
- return MAPSDB::GetUserOptions $userid;
-} # GetUserOptions
-
-sub Login ($$) {
- my ($userid, $password) = @_;
-
- $password = Encrypt $password, $userid;
-
- # Check if user exists
- my $dbpassword = UserExists $userid;
-
- # Return -1 if user doesn't exist
- return -1 if !$dbpassword;
-
- # Return -2 if password does not match
- if ($password eq $dbpassword) {
- MAPSDB::SetContext $userid;
- return 0
- } else {
- return -2
- } # if
-} # Login
-
-sub Nulllist ($;$$) {
- # Nulllist will simply discard the message.
- my ($sender, $sequence, $hit_count) = @_;
-
- RecordHit "null", $sequence, ++$hit_count if $sequence;
-
- # Discard Message
- Logmsg "nulllist", $sender, "Discarded message";
-} # Nulllist
-
-sub OnBlacklist ($;$) {
- my ($sender, $update) = @_;
-
- return CheckOnList "black", $sender, $update;
-} # CheckOnBlacklist
-
-sub OnNulllist ($;$) {
- my ($sender, $update) = @_;
-
- return CheckOnList "null", $sender, $update;
-} # CheckOnNulllist
-
-sub OnWhitelist ($;$$) {
- my ($sender, $userid, $update) = @_;
-
- if (defined $userid) {
- MAPSDB::SetContext $userid;
- } # if
-
- return CheckOnList "white", $sender, $update;
-} # OnWhitelist
-
-sub OptimizeDB () {
- return MAPSDB::OptimizeDB ();
-} # OptimizeDB
-
-sub ReadMsg ($) {
- # Reads an email message file from $input. Returns sender, subject,
- # date and data, which is a copy of the entire message.
- my ($input) = @_;
-
- my $sender = "";
- my $sender_long = "";
- my $envelope_sender = "";
- my $reply_to = "";
- my $subject = "";
- my $data = "";
- my @data;
-
- # Find first message's "From " line indicating start of message
- while (<$input>) {
- chomp;
- last if /^From /;
- } # while
-
- # If we hit eof here then the message was garbled. Return indication of this
- if (eof $input) {
- $data = "Garbled message - unable to find From line";
- return $sender, $sender_long, $reply_to, $subject, $data;
- } # if
-
- if (/From (\S*)/) {
- $envelope_sender = $1;
- $sender_long = $envelope_sender;
- } # if
-
- push @data, $_ if /^From /;
-
- while (<$input>) {
- chomp;
- push @data, $_;
-
- # Blank line indicates start of message body
- last if ($_ eq "" || $_ eq "\r");
-
- # Extract sender's address
- if (/^from: .*/i) {
- $_ = substr ($_, 6);
-
- $sender_long = $_;
-
- if (/<(\S*)@(\S*)>/) {
- $sender = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)\ /) {
- $sender = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)/) {
- $sender = lc ("$1\@$2");
- } # if
- } elsif (/^subject: .*/i) {
- $subject = substr ($_, 9);
- } elsif (/^reply-to: .*/i) {
- $_ = substr ($_, 10);
- if (/<(\S*)@(\S*)>/) {
- $reply_to = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)\ /) {
- $reply_to = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)/) {
- $reply_to = lc ("$1\@$2");
- } # if
- } # if
- } # while
-
- # Read message body
- while (<$input>) {
- chomp;
-
- last if (/^From /);
- push @data, $_;
- } # while
-
- # Set file pointer back by length of the line just read
- seek ($input, -length () - 1, 1) if !eof $input;
-
- # Sanitize email addresses
- $envelope_sender =~ s/\<//g;
- $envelope_sender =~ s/\>//g;
- $envelope_sender =~ s/\"//g;
- $envelope_sender =~ s/\'//g;
- $sender =~ s/\<//g;
- $sender =~ s/\>//g;
- $sender =~ s/\"//g;
- $sender =~ s/\'//g;
- $reply_to =~ s/\<//g;
- $reply_to =~ s/\>//g;
- $reply_to =~ s/\"//g;
- $reply_to =~ s/\'//g;
-
- # Determine best addresses
- $sender = $envelope_sender if $sender eq "";
- $reply_to = $sender if $reply_to eq "";
-
- return $sender, $sender_long, $reply_to, $subject, join "\n", @data;
-} # ReadMsg
-
-sub ResequenceList ($$) {
- my ($userid, $type) = @_;
-
- return MAPSDB::ResequenceList $userid, $type;
-} # ResequenceList
-
-sub ReturnMessages ($$) {
- my ($userid, $sender) = @_;
-
- return MAPSDB::ReturnMessages $userid, $sender;
-} # ReturnMessages
-
-sub ReturnSenders ($$$;$$) {
- my ($userid, $type, $next, $lines, $date) = @_;
-
- return MAPSDB::ReturnSenders $userid, $type, $next, $lines, $date;
-} # ReturnSenders
-
-sub ReturnList ($$$) {
- my ($type, $start_at, $lines) = @_;
-
- return MAPSDB::ReturnList $type, $start_at, $lines;
-} # ReturnList
-
-sub ReturnListEntry ($$) {
- my ($type, $sequence) = @_;
-
- return MAPSDB::ReturnListEntry $type, $sequence;
-} # ReturnList
-
-# Added reply_to. Previously we passed reply_to into here as sender. This
-# caused a problem in that we were filtering as per sender but logging it
-# as reply_to. We only need reply_to for SendMsg so as to honor reply_to
-# so we now pass in both sender and reply_to
-sub ReturnMsg ($$$$) {
- # ReturnMsg will send back to the $sender the register message.
- # Messages are saved to be delivered when the $sender registers.
- my ($sender, $reply_to, $subject, $data) = @_;
-
- # Check to see if this sender has already emailed us.
- my $msg_count = CountMsg $sender;
-
- if ($msg_count < 5) {
- # Return register message
- my @msg;
- foreach (split /\n/,$data) {
- push @msg, "$_\n";
- } # foreach
- SendMsg $reply_to,
- "Your email has been returned by MAPS",
- "$mapsbase/register.html",
- GetContext,
- @msg
- if $msg_count eq 0;
- Logmsg "returned", $sender, "Sent register reply";
- # Save message
- SaveMsg $sender, $subject, $data;
- } else {
- Add2Nulllist $sender, GetContext, "Auto Null List - Mail loop";
- Logmsg "mailloop", $sender, "Mail loop encountered";
- } # if
-} # ReturnMsg
-
-sub SaveMsg ($$$) {
- my ($sender, $subject, $data) = @_;
-
- AddEmail $sender, $subject, $data;
-} # SaveMsg
-
-sub SearchEmails ($$) {
- my ($userid, $searchfield) = @_;
-
- return MAPSDB::SearchEmails $userid, $searchfield;
-} # SearchEmails
-
-sub ForwardMsg ($$$) {
- my ($sender, $subject, $data) = @_;
-
- my @lines = split /\n/, $data;
-
- while ($_ = shift @lines) {
- last if ($_ eq "" || $_ eq "\r");
- } # while
-
- my $to = "renn.leech\@compassbank.com";
-
- my $msg = MIME::Entity->build (
- From => $sender,
- To => $to,
- Subject => $subject,
- Type => "text/html",
- Data => \@lines,
- );
-
- # Send it
- open MAIL, "| /usr/lib/sendmail -t -oi -oem"
- or die "ForwardMsg: Unable to open pipe to sendmail $!";
- $msg->print(\*MAIL);
- close MAIL;
-} # ForwardMsg
-
-sub SendMsg ($$$$@) {
- # SendMsg will send the message contained in $msgfile.
- my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
-
- my @lines;
-
- # Open return message template file
- open RETURN_MSG_FILE, "$msgfile"
- or die "Unable to open return msg file ($msgfile): $!\n";
-
- # Read return message template file and print it to $msg_body
- while (<RETURN_MSG_FILE>) {
- if (/\$userid/) {
- # Replace userid
- s/\$userid/$userid/;
- } # if
- if (/\$sender/) {
- # Replace sender
- s/\$sender/$sender/;
- } #if
- push @lines, $_;
- } # while
-
- # Close RETURN_MSG_FILE
- close RETURN_MSG_FILE;
-
- # Create the message, and set up the mail headers:
- my $msg = MIME::Entity->build (
- From => "MAPS\@DeFaria.com",
- To => $sender,
- Subject => $subject,
- Type => "text/html",
- Data => \@lines
- );
-
- # Need to obtain the spam message here...
- $msg->attach (
- Type => "message",
- Disposition => "attachment",
- Data => \@spammsg
- );
-
- # Send it
- open MAIL, "| /usr/lib/sendmail -t -oi -oem"
- or die "SendMsg: Unable to open pipe to sendmail $!";
- $msg->print(\*MAIL);
- close MAIL;
-} # SendMsg
-
-sub SetContext ($) {
- my ($new_user) = @_;
-
- return MAPSDB::SetContext $new_user;
-} # SetContext
-
-sub Space ($) {
- my ($userid) = @_;
-
- return MAPSDB::Space $userid;
-} # Space
-
-sub UpdateList ($$$$$$$) {
- my ($userid, $type, $pattern, $domain, $comment, $hit_count, $sequence) = @_;
-
- return MAPSDB::UpdateList $userid, $type, $pattern, $domain, $comment, $hit_count, $sequence;
-} # UpdateList
-
-sub UpdateUser ($$$$) {
- my ($userid, $fullname, $email, $password) = @_;
-
- return MAPSDB::UpdateUser $userid, $fullname, $email, $password;
-} # UpdateUser
-
-sub UpdateUserOptions ($@) {
- my ($userid, %options) = @_;
-
- my $status;
-
- foreach (keys (%options)) {
- $status = MAPSDB::UpdateUserOption $userid, $_, $options{$_};
- last if $status ne 0;
- }
-
- return $status;
-} # UpdateUserOptions
-
-sub UserExists ($) {
- my ($userid) = @_;
-
- return MAPSDB::UserExists $userid
-} # UserExists
-
-sub Whitelist ($$;$$) {
- # Whitelist will deliver the message.
- my ($sender, $data, $sequence, $hit_count) = @_;
-
- my $userid = GetContext;
-
- # Dump message into a file
- open MESSAGE, ">/tmp/MAPSMessage.$$"
- or Error "Unable to open message file (/tmp/MAPSMessage.$$): $!\n", return -1;
-
- print MESSAGE $data;
-
- close MESSAGE;
-
- # Now call MAPSDeliver
- my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
-
- unlink "/tmp/MAPSMessage.$$";
-
- if ($status eq 0) {
- Logmsg "whitelist", $sender, "Delivered message";
- } else {
- Error "Unable to deliver message - is MAPSDeliver setgid? - $!";
- } # if
-
- RecordHit "white", $sequence, ++$hit_count if $sequence;
-
- return $status;
-} # Whitelist
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-#################################################################################
-#
-# File: $RCSfile: MAPSDB.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: MAPS Database routines
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPSDB;
-
-use strict;
-use vars qw (@ISA @EXPORT);
-use DBI;
-use Carp;
-
-use MAPSUtil;
-
-@ISA = qw (Exporter);
-
-# Globals
-my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
-my %useropts;
-my $DB;
-
-@EXPORT = qw (
- AddLog
- CheckOnList
- CloseDB
- DBError
- OpenDB
- RecordHit
-);
-
-# Forwards
-sub AddEmail;
-sub AddList;
-sub AddLog;
-sub AddUser;
-sub AddUserOption;
-sub CheckOnList;
-sub CleanEmail;
-sub CleanLog;
-sub CleanList;
-sub CloseDB;
-sub CountMsg;
-sub DBError;
-sub Decrypt;
-sub DeleteEmail;
-sub DeleteList;
-sub Encrypt;
-sub FindEmail;
-sub FindList;
-sub FindLog;
-sub FindUser;
-sub GetContext;
-sub GetEmail;
-sub GetList;
-sub GetLog;
-sub GetNextSequenceNo;
-sub GetUser;
-sub GetUserInfo;
-sub GetUserOptions;
-sub OpenDB;
-sub OptimizeDB;
-sub ResequenceList;
-sub ReturnEmails;
-sub ReturnList;
-sub ReturnListEntry;
-sub SetContext;
-sub Space;
-sub UpdateList;
-sub UpdateUser;
-sub UpdateUserOption;
-sub UserExists;
-sub count;
-sub countlog;
-
-sub AddEmail ($$$) {
- my ($sender, $subject, $data) = @_;
-
- # "Sanitize" some fields so that characters that are illegal to SQL are escaped
- $sender = 'Unknown'
- if (!defined $sender || $sender eq '');
- $sender = $DB->quote ($sender);
- $subject = $DB->quote ($subject);
- $data = $DB->quote ($data);
-
- my $timestamp = UnixDatetime2SQLDatetime (scalar (localtime));
- my $statement = "insert into email values (\"$userid\", $sender, $subject, \"$timestamp\", $data)";
-
- $DB->do ($statement)
- or DBError 'AddEmail: Unable to do statement', $statement;
-
- return;
-} # AddEmail
-
-sub AddList ($$$;$$$) {
- my ($listtype, $pattern, $sequence, $comment, $hitcount, $last_hit) = @_;
-
- $hitcount ||= 0;
-
- my ($user, $domain) = split /\@/, $pattern;
-
- if (!$domain || $domain eq '') {
- $domain = 'NULL';
- $pattern = $DB->quote ($user);
- } else {
- $domain = "'$domain'";
- if ($user eq '') {
- $pattern = 'NULL';
- } else {
- $pattern = $DB->quote ($user);
- } # if
- } # if
-
- if (!$comment || $comment eq '') {
- $comment = 'NULL';
- } else {
- $comment = $DB->quote ($comment);
- } # if
-
- # Get next sequence #
- if ($sequence == 0) {
- $sequence = GetNextSequenceNo $userid, $listtype;
- } # if
-
- $last_hit //= UnixDatetime2SQLDatetime (scalar (localtime));
-
- my $statement = "insert into list values (\"$userid\", \"$listtype\", $pattern, $domain, $comment, $sequence, $hitcount, \"$last_hit\")";
-
- $DB->do ($statement)
- or DBError 'AddList: Unable to do statement', $statement;
-
- return;
-} # AddList
-
-sub AddLog ($$$) {
- my ($type, $sender, $msg) = @_;
-
- my $timestamp = UnixDatetime2SQLDatetime (scalar (localtime));
- my $statement;
-
- # Use quote to protect ourselves
- $msg = $DB->quote ($msg);
-
- if ($sender eq '') {
- $statement = "insert into log values (\"$userid\", \"$timestamp\", null, \"$type\", $msg)";
- } else {
- $statement = "insert into log values (\"$userid\", \"$timestamp\", \"$sender\", \"$type\", $msg)";
- } # if
-
- $DB->do ($statement)
- or DBError 'AddLog: Unable to do statement', $statement;
-
- return;
-} # AddLog
-
-sub AddUser ($$$$) {
- my ($userid, $realname, $email, $password) = @_;
-
- $password = Encrypt $password, $userid;
-
- if (UserExists $userid) {
- return 1;
- } else {
- my $statement = "insert into user values ('$userid', '$realname', '$email', '$password')";
-
- $DB->do ($statement)
- or DBError 'AddUser: Unable to do statement', $statement;
- } # if
-
- return 0;
-} # AddUser
-
-sub AddUserOption ($$$) {
- my ($userid, $name, $value) = @_;
-
- if (!UserExists $userid) {
- return 1;
- } # if
-
- my $statement = "insert into useropts values ('$userid', '$name', '$value')";
-
- $DB->do ($statement)
- or DBError 'AddUserOption: Unable to do statement', $statement;
-
- return 0;
-} # AddUserOption
-
-sub RecordHit ($$$) {
- my ($listtype, $sequence, $hit_count) = @_;
-
- my $current_date = UnixDatetime2SQLDatetime (scalar (localtime));
-
- my $statement = "update list set hit_count=$hit_count, last_hit='$current_date' where userid='$userid' and type='$listtype' and sequence=$sequence";
-
- $DB->do ($statement)
- or DBError 'AddList: Unable to do statement', $statement;
-
- return;
-} # RecordHit
-
-sub CheckOnList ($$;$) {
- # CheckOnList will check to see if the $sender is on the $listfile.
- # Return 1 if found 0 if not.
- my ($listtype, $sender, $update) = @_;
-
- $update //= 1;
-
- my $status = 0;
- my ($rule, $sequence, $hit_count);
-
- my $statement = "select pattern, domain, comment, sequence, hit_count from list where userid = '$userid' and type = '$listtype'";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'CheckOnList: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'CheckOnList: Unable to execute statement', $statement;
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
-
- $hit_count = pop (@row);
- $sequence = pop (@row);
- my $comment = pop (@row);
- my $domain = pop (@row);
- my $pattern = pop (@row);
- my $email_on_file;
-
- unless ($domain) {
- $email_on_file = $pattern;
- } else {
- unless ($pattern) {
- $email_on_file = '@' . $domain;
- } else {
- $email_on_file = $pattern . '@' . $domain;
- } # if
- } # unless
-
- # Escape some special characters
- $email_on_file =~ s/\@/\\@/;
- $email_on_file =~ s/^\*/.\*/;
-
- # We want to terminate the search string with a "$" iff there's an
- # "@" in there. This is because some "email_on_file" may have no
- # domain (e.g. "mailer-daemon" with no domain). In that case we
- # don't want to terminate the search string with a "$" rather we
- # wish to terminate it with an "@". But in the case of say
- # "@ti.com" if we don't terminate the search string with "$" then
- # "@ti.com" would also match "@tixcom.com"!
- my $search_for = $email_on_file =~ /\@/
- ? "$email_on_file\$"
- : !defined $domain
- ? "$email_on_file\@"
- : $email_on_file;
-
- if ($sender =~ /$search_for/i) {
- $rule = "Matching rule: ($listtype:$sequence) \"$email_on_file\"";
- $rule .= " - $comment" if $comment and $comment ne '';
- $status = 1;
-
- RecordHit $listtype, $sequence, ++$hit_count if $update;
-
- last;
- } # if
- } # while
-
- $sth->finish;
-
- return ($status, $rule, $sequence, $hit_count);
-} # CheckOnList
-
-sub CleanEmail ($) {
- my ($timestamp) = @_;
-
- # First see if anything needs to be deleted
- my $count = 0;
-
- my $statement = "select count(*) from email where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- my $sth = $DB->prepare ($statement)
- or DBError 'CleanEmail: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'CleanEmail: Unable to execute statement', $statement;
-
- # Get return value, which should be how many entries were deleted
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- unless ($row[0]) {
- $count = 0
- } else {
- $count = $row[0];
- } # unless
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- # Delete emails for userid whose older than $timestamp
- $statement = "delete from email where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- $sth = $DB->prepare ($statement)
- or DBError 'CleanEmail: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'CleanEmail: Unable to execute statement', $statement;
-
- return $count;
-} # CleanEmail
-
-sub CleanLog ($) {
- my ($timestamp) = @_;
-
- # First see if anything needs to be deleted
- my $count = 0;
-
- my $statement = "select count(*) from log where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- my $sth = $DB->prepare ($statement)
- or DBError $DB, 'CleanLog: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'CleanLog: Unable to execute statement', $statement;
-
- # Get return value, which should be how many entries were deleted
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- unless ($row[0]) {
- $count = 0
- } else {
- $count = $row[0];
- } # unless
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- # Delete log entries for userid whose older than $timestamp
- $statement = "delete from log where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- $sth = $DB->prepare ($statement)
- or DBError 'CleanLog: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'CleanLog: Unable to execute statement', $statement;
-
- return $count;
-} # CleanLog
-
-sub CleanList ($;$) {
- my ($timestamp, $listtype) = @_;
-
- $listtype = 'null' if !$listtype;
-
- # First see if anything needs to be deleted
- my $count = 0;
-
- my $statement = "select count(*) from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
-
- # Prepare statement
- my $sth = $DB->prepare ($statement)
- or DBError $DB, 'CleanList: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'CleanList: Unable to execute statement', $statement;
-
- # Get return value, which should be how many entries were deleted
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- $count = $row[0] ? $row[0] : 0;
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- # Get data for these entries
- $statement = "select type, sequence, hit_count from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
-
- # Prepare statement
- $sth = $DB->prepare ($statement)
- or DBError 'CleanList: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'CleanList: Unable to execute statement', $statement;
-
- $count = 0;
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
-
- my $hit_count = pop (@row);
- my $sequence = pop (@row);
- my $listtype = pop (@row);
-
- if ($hit_count == 0) {
- $count++;
-
- $statement = "delete from list where userid='$userid' and type='$listtype' and sequence=$sequence";
- $DB->do ($statement)
- or DBError 'CleanList: Unable to execute statement', $statement;
- } else {
- # Age entry: Sometimes entries are initially very popular and
- # the $hit_count gets very high quickly. Then the domain is
- # abandoned and no activity happens. One case recently observed
- # was for phentermine.com. The $hit_count initially soared to
- # 1920 within a few weeks. Then it all stopped as of
- # 07/13/2007. Obvisously this domain was shutdown. With the
- # previous aging algorithm of simply subtracting 1 this
- # phentermine.com entry would hang around for over 5 years!
- #
- # So the tack here is to age the entry by dividing it's
- # $hit_count in half. Sucessive halfing then will quickly age
- # the entry down to size. However we don't want to age small
- # $hit_count's too quickly, therefore once their numbers drop to
- # < 30 we revert to the old method of subtracting 1.
- if ($hit_count < 30) {
- $hit_count--;
- } else {
- $hit_count = $hit_count / 2;
- } # if
-
- $statement = "update list set hit_count=$hit_count where userid='$userid' and type='$listtype' and sequence=$sequence;";
- $DB->do ($statement)
- or DBError 'CleanList: Unable to execute statement', $statement;
- } # if
- } # while
-
- ResequenceList $userid, $listtype if $count > 0;
-
- return $count;
-} # CleanList
-
-sub CloseDB () {
- $DB->disconnect;
-
- return;
-} # CloseDB
-
-sub CountMsg ($) {
- my ($sender) = @_;
-
- return count ('email', "userid = '$userid' and sender like '%$sender%'");
-} # CountMsg
-
-sub DBError ($$) {
- my ($msg, $statement) = @_;
-
- print 'MAPSDB::' . $msg . "\nError #" . $DB->err . ' ' . $DB->errstr . "\n";
-
- if ($statement) {
- print "SQL Statement: $statement\n";
- } # if
-
- exit $DB->err;
-} # DBError
-
-sub Decrypt ($$) {
- my ($password, $userid) = @_;
-
- my $statement = "select decode('$password','$userid')";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'Decrypt: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'Decrypt: Unable to execute statement', $statement;
-
- # Get return value, which should be the encoded password
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- return $row[0]
-} # Decrypt
-
-sub DeleteEmail ($) {
- my $sender = shift;
-
- my ($username, $domain) = split /@/, $sender;
- my $condition;
-
- if ($username eq '') {
- $condition = "userid = '$userid' and sender like '%\@$domain'";
- } else {
- $condition = "userid = '$userid' and sender = '$sender'";
- } # if
-
- # First see if anything needs to be deleted
- my $count = count ('email', $condition);
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- my $statement = 'delete from email where ' . $condition;
-
- $DB->do ($statement)
- or DBError 'DeleteEmail: Unable to execute statement', $statement;
-
- return $count;
-} # DeleteEmail
-
-sub DeleteList ($$) {
- my ($type, $sequence) = @_;
-
- # First see if anything needs to be deleted
- my $count = count ('list', "userid = '$userid' and type = '$type' and sequence = '$sequence'");
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- my $statement = "delete from list where userid = '$userid' and type = '$type' and sequence = '$sequence'";
-
- $DB->do ($statement)
- or DBError 'DeleteList: Unable to execute statement', $statement;
-
- return $count;
-} # DeleteList
-
-sub DeleteLog ($) {
- my ($sender) = @_;
-
- my ($username, $domain) = split /@/, $sender;
- my $condition;
-
- if ($username eq '') {
- $condition = "userid = '$userid' and sender like '%\@$domain'";
- } else {
- $condition = "userid = '$userid' and sender = '$sender'";
- } # if
-
- # First see if anything needs to be deleted
- my $count = count ('log', $condition);
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- my $statement = 'delete from log where ' . $condition;
-
- $DB->do ($statement)
- or DBError 'DeleteLog: Unable to execute statement', $statement;
-
- return $count;
-} # DeleteLog
-
-sub Encrypt ($$) {
- my ($password, $userid) = @_;
-
- my $statement = "select encode('$password','$userid')";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'Encrypt: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'Encrypt: Unable to execute statement', $statement;
-
- # Get return value, which should be the encoded password
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- return $row[0]
-} # Encrypt
-
-sub FindEmail (;$) {
- my ($sender) = @_;
-
- my $statement;
-
- if (!defined $sender || $sender eq '') {
- $statement = "select * from email where userid = '$userid'";
- } else {
- $statement = "select * from email where userid = '$userid' and sender = '$sender'";
- } # if
-
- my $sth = $DB->prepare ($statement)
- or DBError 'FindEmail: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'FindEmail: Unable to execute statement', $statement;
-
- return $sth;
-} # FindEmail
-
-sub FindList ($;$) {
- my ($type, $sender) = @_;
-
- my $statement;
-
- unless ($sender) {
- $statement = "select * from list where userid = '$userid' and type = '$type'";
- } else {
- my ($pattern, $domain) = split /\@/, $sender;
- $statement = "select * from list where userid = '$userid' and type = '$type' " .
- "and pattern = '$pattern' and domain = '$domain'";
- } # unless
-
- # Prepare statement
- my $sth = $DB->prepare ($statement)
- or DBError 'FindList: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'FindList: Unable to execute statement', $statement;
-
- # Get return value, which should be how many entries were deleted
- return $sth;
-} # FindList
-
-sub FindLog ($$) {
- my ($start_at, $end_at) = @_;
-
- my $statement = "select * from log where userid = '$userid' order by timestamp limit $start_at, $end_at";
-
- # Prepare statement
- my $sth = $DB->prepare ($statement)
- or DBError 'FindLog: Unable to prepare statement', $statement;
-
- # Execute statement
- $sth->execute
- or DBError 'FindLog: Unable to execute statement', $statement;
-
- # Get return value, which should be how many entries were deleted
- return $sth;
-} # FindLog
-
-sub FindUser (;$) {
- my ($userid) = @_;
-
- my $statement;
-
- if (!defined $userid || $userid eq '') {
- $statement = 'select * from user';
- } else {
- $statement = "select * from user where userid = '$userid'";
- } # if
-
- my $sth = $DB->prepare ($statement)
- or DBError 'FindUser: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'FindUser: Unable to execute statement', $statement;
-
- return $sth;
-} # FindUser
-
-sub GetContext () {
- return $userid;
-} # GetContext
-
-sub GetEmail ($) {
- my ($sth) = @_;
-
- my @email;
-
- if (@email = $sth->fetchrow_array) {
- my $message = pop @email;
- my $timestamp = pop @email;
- my $subject = pop @email;
- my $sender = pop @email;
- my $userid = pop @email;
- return $userid, $sender, $subject, $timestamp, $message;
- } else {
- return;
- } # if
-} # GetEmail
-
-sub GetList ($) {
- my ($sth) = @_;
-
- my @list;
-
- if (@list = $sth->fetchrow_array) {
- my $last_hit = pop @list;
- my $hit_count = pop @list;
- my $sequence = pop @list;
- my $comment = pop @list;
- my $domain = pop @list;
- my $pattern = pop @list;
- my $type = pop @list;
- my $userid = pop @list;
- return $userid, $type, $pattern, $domain, $comment, $sequence, $hit_count, $last_hit;
- } else {
- return;
- } # if
-} # GetList
-
-sub GetLog ($) {
- my ($sth) = @_;
-
- my @log;
-
- if (@log = $sth->fetchrow_array) {
- my $message = pop @log;
- my $type = pop @log;
- my $sender = pop @log;
- my $timestamp = pop @log;
- my $userid = pop @log;
- return $userid, $timestamp, $sender, $type, $message;
- } else {
- return;
- } # if
-} # GetLog
-
-sub GetNextSequenceNo ($$) {
- my ($userid, $listtype) = @_;
-
- my $count = count ('list', "userid = '$userid' and type = '$listtype'");
-
- return $count + 1;
-} # GetNextSequenceNo
-
-sub GetUser ($) {
- my ($sth) = @_;
-
- my @user;
-
- if (@user = $sth->fetchrow_array) {
- my $password = pop @user;
- my $email = pop @user;
- my $name = pop @user;
- my $userid = pop @user;
- return ($userid, $name, $email, $password);
- } else {
- return;
- } # if
-} # GetUser
-
-sub GetUserInfo ($) {
- my ($userid) = @_;
-
- my $statement = "select name, email from user where userid='$userid'";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'GetUserInfo: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'GetUserInfo: Unable to execute statement', $statement;
-
- my @userinfo = $sth->fetchrow_array;
- my $user_email = lc (pop @userinfo);
- my $username = lc (pop @userinfo);
-
- $sth->finish;
-
- return ($username, $user_email);
-} # GetUserInfo
-
-sub GetUserOptions ($) {
- my ($userid) = @_;
-
- my $statement = "select * from useropts where userid = '$userid'";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'GetUserOptions: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'GetUserOptions: Unable to execute statement', $statement;
-
- my @useropts;
-
- # Empty hash
- %useropts = ();
-
- while (@useropts = $sth->fetchrow_array) {
- my $value = pop @useropts;
- my $name = pop @useropts;
- pop @useropts;
- $useropts{$name} = $value;
- } # while
-
- $sth->finish;
-
- return %useropts;
-} # GetUserOptions
-
-sub GetRows ($) {
- my ($statement) = @_;
-
- my $sth = $DB->prepare ($statement)
- or DBError 'Unable to prepare statement' , $statement;
-
- $sth->execute
- or DBError 'Unable to execute statement' , $statement;
-
- my @array;
-
- while (my @row = $sth->fetchrow_array) {
- foreach (@row) {
- push @array, $_;
- } # foreach
- } # while
-
- return @array;
-} # GetRows
-
-sub OpenDB ($$) {
- my ($username, $password) = @_;
-
- my $dbname = 'MAPS';
- my $dbdriver = 'mysql';
- my $dbserver = $ENV{MAPS_SERVER} || 'localhost';
-
- if (!$DB || $DB eq '') {
- #$dbserver='localhost';
- $DB = DBI->connect("DBI:$dbdriver:$dbname:$dbserver", $username, $password, {PrintError => 0})
- or croak "Couldn't connect to $dbname database as $username\n" . $DBI::errstr;
- } # if
-
- return $DB;
-} # OpenDB
-
-sub OptimizeDB () {
- my $statement = 'lock tables email read, list read, log read, user read, useropts read';
- my $sth = $DB->prepare ($statement)
- or DBError 'OptimizeDB: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'OptimizeDB: Unable to execute statement', $statement;
-
- $statement = 'check table email, list, log, user, useropts';
- $sth = $DB->prepare ($statement)
- or DBError 'OptimizeDB: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'OptimizeDB: Unable to execute statement', $statement;
-
- $statement = 'unlock tables';
- $sth = $DB->prepare ($statement)
- or DBError 'OptimizeDB: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'OptimizeDB: Unable to execute statement', $statement;
-
- $statement = 'optimize table email, list, log, user, useropts';
- $sth = $DB->prepare ($statement)
- or DBError 'OptimizeDB: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'OptimizeDB: Unable to execute statement', $statement;
-
- return;
-} # OptimizeDB
-
-sub ResequenceList ($$) {
- my ($userid, $type) = @_;
-
- if ($type ne 'white' && $type ne 'black' && $type ne 'null') {
- return 1;
- } # if
-
- if (!UserExists $userid) {
- return 2;
- } # if
-
- my $statement = "select sequence from list where userid = '$userid' ".
- " and type = '$type' order by sequence";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'ResequenceList: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'ResequenceList: Unable to execute statement', $statement;
-
- my $sequence = 1;
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
- my $old_sequence = pop (@row);
-
- if ($old_sequence != $sequence) {
- my $update_statement = "update list set sequence = $sequence " .
- "where userid = '$userid' and " .
- "type = '$type' and sequence = $old_sequence";
- $DB->do ($update_statement)
- or DBError 'ResequenceList: Unable to do statement', $statement;
- } # if
-
- $sequence++;
- } # while
-
- return 0;
-} # ResequenceList
-
-# This subroutine returns an array of senders in reverse chronological
-# order based on time timestamp from the log table of when we returned
-# their message. The complication here is that a single sender may
-# send multiple times in a single day. So if spammer@foo.com sends
-# spam @ 1 second after midnight and then again at 2 Pm there will be
-# at least two records in the log table saying that we returned his
-# email. Getting records sorted by timestamp desc will have
-# spammer@foo.com listed twice. But we want him listed only once, as
-# the first entry in the returned array. Plus we may be called
-# repeatedly with different $start_at's. Therefore we need to process
-# the whole list of returns for today, eliminate duplicate entries for
-# a single sender then slice the resulting array.
-sub ReturnSenders ($$$;$$) {
- my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
-
- $start_at ||= 0;
-
- my $dateCond = '';
-
- if ($date) {
- my $sod = $date . ' 00:00:00';
- my $eod = $date . ' 23:59:59';
-
- $dateCond = "and timestamp > '$sod' and timestamp < '$eod'";
- } # if
-
- my $statement = <<"END";
-select
- sender,
- timestamp
-from
- log
-where
- userid = '$userid' and
- type = '$type'
- $dateCond
-order by
- timestamp desc
-END
-
- my $sth = $DB->prepare ($statement)
- or DBError 'ReturnSenders: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'ReturnSenders: Unable to execute statement', $statement;
-
- # Watch the distinction between senders (plural) and sender (singular)
- my (%senders, %sendersByTimestamp);
-
- # Run through the results and add to %senders by sender key. This
- # results in a hash that has the sender in it and the first
- # timestamp value. Since we already sorted timestamp desc by the
- # above select statement, and we've narrowed it down to only log
- # message that occurred for the given $date, we will have a hash
- # containing 1 sender and the latest timestamp for the day.
- while (my $senderRef = $sth->fetchrow_hashref) {
- my %sender = %{$senderRef};
-
- $senders{$sender{sender}} = $sender{timestamp}
- unless $senders{$sender{sender}};
- } # while
-
- $sth->finish;
-
- # Make a hash whose keys are the timestamp (so we can later sort on
- # them).
- while (my ($key, $value) = each %senders) {
- $sendersByTimestamp{$value} = $key;
- } # while
-
- my @senders;
-
- # Sort by timestamp desc and push on to the @senders array
- push @senders, $sendersByTimestamp{$_}
- foreach (sort { $b cmp $a } keys %sendersByTimestamp);
-
- # Finally slice for the given range
- my $end_at = $start_at + $nbr_emails - 1;
-
- $end_at = (@senders - 1)
- if $end_at > @senders;
-
- return (@senders) [$start_at .. $end_at];
-} # ReturnSenders
-
-sub ReturnMessages ($$) {
- my ($userid, $sender) = @_;
-
- my $statement = <<"END";
-select
- subject,
- timestamp
-from
- email
-where
- userid = '$userid' and
- sender = '$sender'
-group by
- timestamp desc
-END
-
- my $sth = $DB->prepare ($statement)
- or DBError 'ReturnMessages: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'ReturnMessages: Unable to execute statement', $statement;
-
- my @messages;
-
- while (my @row = $sth->fetchrow_array) {
- my $date = pop @row;
- my $subject = pop @row;
-
- push @messages, [$subject, $date];
- } # while
-
- $sth->finish;
-
- return @messages;
-} # ReturnMessages
-
-sub ReturnEmails ($$$;$$) {
- my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
-
- $start_at ||= 0;
-
- my $statement;
-
- if ($date) {
- my $sod = $date . ' 00:00:00';
- my $eod = $date . ' 23:59:59';
-
- if ($type eq 'returned') {
- $statement = <<"END";
-select
- log.sender
-from
- log,
- email
-where
- log.sender = email.sender and
- log.userid = '$userid' and
- log.timestamp > '$sod' and
- log.timestamp < '$eod' and
- log.type = '$type'
-group by
- log.sender
-limit
- $start_at, $nbr_emails
-END
- } else {
- $statement = <<"END";
-select
- sender
-from
- log
-where
- userid = '$userid' and
- timestamp > '$sod' and
- timestamp < '$eod' and
- type = '$type'
-group by
- sender
-limit
- $start_at, $nbr_emails
-END
- } # if
- } else {
- if ($type eq 'returned') {
- $statement = <<"END";
-select
- log.sender
-from
- log,
- email
-where
- log.sender = email.sender and
- log.userid = '$userid' and
- log.type = '$type'
-group by
- log.sender
-order by
- log.timestamp desc
-limit
- $start_at, $nbr_emails
-END
- } else {
- $statement = <<"END";
-select
- sender
-from
- log
-where
- userid = '$userid' and
- type = '$type'
-group by
- sender
-order by
- timestamp desc
-limit
- $start_at, $nbr_emails
-END
- } # if
- } # if
-
- my $sth = $DB->prepare ($statement)
- or DBError 'ReturnEmails: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'ReturnEmails: Unable to execute statement', $statement;
-
- my @emails;
-
- while (my $sender = $sth->fetchrow_array) {
- my $earliestDate;
-
- # Get emails for this sender. Format an array of subjects and timestamps.
- my @messages;
-
- $statement = "select timestamp, subject from email where userid = '$userid' " .
- "and sender = '$sender'";
-
- my $sth2 = $DB->prepare ($statement)
- or DBError 'ReturnEmails: Unable to prepare statement', $statement;
-
- $sth2->execute
- or DBError 'ReturnEmails: Unable to execute statement', $statement;
-
- while (my @row = $sth2->fetchrow_array) {
- my $subject = pop @row;
- my $date = pop @row;
-
- if ($earliestDate) {
- my $earliestDateShort = substr $earliestDate, 0, 10;
- my $dateShort = substr $date, 0, 10;
-
- if ($earliestDateShort eq $dateShort and
- $earliestDate > $date) {
- $earliestDate = $date
- if $earliestDateShort eq $dateShort;
- } # if
- } else {
- $earliestDate = $date;
- } # if
-
- push @messages, [$subject, $date];
- } # while
-
- # Done with sth2
- $sth2->finish;
-
- $earliestDate ||= '';
-
- unless ($type eq 'returned') {
- push @emails, [$earliestDate, [$sender, @messages]];
- } else {
- push @emails, [$earliestDate, [$sender, @messages]]
- if @messages > 0;
- } # unless
- } # while
-
- # Done with $sth
- $sth->finish;
-
- return @emails;
-} # ReturnEmails
-
-sub ReturnList ($$$) {
- my ($type, $start_at, $lines) = @_;
-
- $lines ||= 10;
-
- my $statement;
-
- if ($start_at) {
- $statement = "select * from list where userid = '$userid' " .
- "and type = '$type' order by sequence " .
- "limit $start_at, $lines";
- } else {
- $statement = "select * from list where userid = '$userid' " .
- "and type = '$type' order by sequence";
- } # if
-
- my $sth = $DB->prepare ($statement)
- or DBError 'ReturnList: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'ReturnList: Unable to execute statement', $statement;
-
- my @list;
- my $i = 0;
-
- while (my @row = $sth->fetchrow_array) {
- last if $i++ > $lines;
-
- my %list;
-
- $list {last_hit} = pop @row;
- $list {hit_count} = pop @row;
- $list {sequence} = pop @row;
- $list {comment} = pop @row;
- $list {domain} = pop @row;
- $list {pattern} = pop @row;
- $list {type} = pop @row;
- $list {userid} = pop @row;
- push @list, \%list;
- } # for
-
- return @list;
-} # ReturnList
-
-sub ReturnListEntry ($$) {
- my ($type, $sequence) = @_;
-
- my $statement = "select * from list where userid = '$userid' " .
- "and type = '$type' and sequence = '$sequence'";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'ReturnListEntry: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'ReturnListEntry: Unable to execute statement', $statement;
-
- my %list;
- my @row = $sth->fetchrow_array;
-
- $list {sequence} = pop @row;
- $list {comment} = pop @row;
- $list {domain} = pop @row;
- $list {pattern} = pop @row;
- $list {type} = pop @row;
- $list {userid} = pop @row;
-
- return %list;
-} # ReturnListEntry
-
-sub UpdateList ($$$$$$$) {
- my ($userid, $type, $pattern, $domain, $comment, $hit_count, $sequence) = @_;
-
- if (!$pattern || $pattern eq '') {
- $pattern = 'NULL';
- } else {
- $pattern = "'" . quotemeta ($pattern) . "'";
- } # if
-
- if (!$domain || $domain eq '') {
- $domain = 'NULL';
- } else {
- $domain = "'" . quotemeta ($domain) . "'";
- } # if
-
- if (!$comment || $comment eq '') {
- $comment = 'NULL';
- } else {
- $comment = "'" . quotemeta ($comment) . "'";
- } # if
-
- if (!$hit_count || $hit_count eq '') {
- $hit_count = 0;
- #} else {
- # TODO: Check if numeric
- } # fi
-
- my $statement =
- 'update list set ' .
- "pattern = $pattern, domain = $domain, comment = $comment, hit_count = $hit_count " .
- "where userid = '$userid' and type = '$type' and sequence = $sequence";
-
- $DB->do ($statement)
- or DBError 'UpdateList: Unable to do statement', $statement;
-
- return 0;
-} # UpdateList
-
-sub SearchEmails ($$) {
- my ($userid, $searchfield) = @_;
-
- my @emails;
-
- my $statement =
- "select sender, subject, timestamp from email where userid = '$userid' and (
- sender like '%$searchfield%' or subject like '%$searchfield%')
- order by timestamp desc";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'SearchEmails: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'SearchEmails: Unable to execute statement', $statement;
-
- while (my @row = $sth->fetchrow_array) {
- my $date = pop @row;
- my $subject = pop @row;
- my $sender = pop @row;
-
- push @emails, [$sender, $subject, $date];
- } # while
-
- $sth->finish;
-
- return @emails;
-} # SearchEmails
-
-sub SetContext ($) {
- my ($to_user) = @_;
-
- my $old_user = $userid;
-
- if (UserExists $to_user) {
- $userid = $to_user;
- GetUserOptions $userid;
- return GetUserInfo $userid;
- } else {
- return 0;
- } # if
-} # SetContext
-
-sub Space ($) {
- my ($userid) = @_;
-
- my $total_space = 0;
- my %msg_space;
-
- my $statement = "select * from email where userid = '$userid'";
- my $sth = $DB->prepare ($statement)
- or DBError 'Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'Unable to execute statement', $statement;
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
- my $data = pop @row;
- my $timestamp = pop @row;
- my $subject = pop @row;
- my $sender = pop @row;
- my $user = pop @row;
-
- my $msg_space =
- length ($userid) +
- length ($sender) +
- length ($subject) +
- length ($timestamp) +
- length ($data);
-
- $total_space += $msg_space;
- $msg_space{$sender} += $msg_space;
- } # while
-
- $sth->finish;
-
- return wantarray ? %msg_space : $total_space;
-} # Space
-
-sub UpdateUser ($$$$) {
- my ($userid, $fullname, $email, $password) = @_;
-
- if (!UserExists $userid) {
- return 1;
- } # if
-
- my $statement;
-
- if (!defined $password || $password eq '') {
- $statement = "update user set userid='$userid', name='$fullname', email='$email' where userid='$userid'";
- } else {
- $password = Encrypt $password, $userid;
- $statement = "update user set userid='$userid', name='$fullname', email='$email', password='$password' where userid='$userid'";
- } # if
-
- $DB->do ($statement)
- or DBError 'UpdateUser: Unable to do statement', $statement;
-
- return 0;
-} # UpdateUser
-
-sub UpdateUserOption ($$$) {
- my ($userid, $name, $value) = @_;
-
- if (!UserExists $userid) {
- return 1;
- } # if
-
- my $statement = "update useropts set value='$value' where userid='$userid' and name='$name'";
-
- $DB->do ($statement)
- or DBError 'UpdateUserOption: Unable to do statement', $statement;
-
- return 0;
-} # UpdateUserOptions
-
-sub UserExists ($) {
- my ($userid) = @_;
-
- return 0
- unless $userid;
-
- my $statement = "select userid, password from user where userid = '$userid'";
-
- my $sth = $DB->prepare ($statement)
- or DBError 'UserExists: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'UserExists: Unable to execute statement', $statement;
-
- my @userdata = $sth->fetchrow_array;
-
- $sth->finish;
-
- return 0 if scalar (@userdata) == 0;
-
- my $dbpassword = pop @userdata;
- my $dbuserid = pop @userdata;
-
- if ($dbuserid ne $userid) {
- return 0;
- } else {
- return $dbpassword;
- } # if
-} # UserExists
-
-sub count ($$) {
- my ($table, $condition) = @_;
-
- my $statement;
-
- if ($condition) {
- $statement = "select count(*) from $table where $condition";
- } else {
- $statement = "select count(*) from $table";
- } # if
-
- my $sth = $DB->prepare ($statement)
- or DBError 'count: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'count: Unable to execute statement', $statement;
-
- # Get return value, which should be how many message there are
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- my $count;
-
- # Retrieve returned value
- unless ($row[0]) {
- $count = 0
- } else {
- $count = $row[0];
- } # unless
-
- return $count
-} # count
-
-sub count_distinct ($$$) {
- my ($table, $column, $condition) = @_;
-
- my $statement;
-
- if ($condition) {
- $statement = "select count(distinct $column) from $table where $condition";
- } else {
- $statement = "select count(distinct $column) from $table";
- } # if
-
- my $sth = $DB->prepare ($statement)
- or DBError 'count: Unable to prepare statement', $statement;
-
- $sth->execute
- or DBError 'count: Unable to execute statement', $statement;
-
- # Get return value, which should be how many message there are
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- unless ($row[0]) {
- return 0;
- } else {
- return $row[0];
- } # unless
-} # count_distinct
-
-sub countlog (;$$) {
- my ($additional_condition, $type) = @_;
-
- $type ||= '';
-
- my $condition;
-
- $condition = "userid=\'$userid\' ";
-
- $condition .= "and $additional_condition"
- if $additional_condition;
-
- return count_distinct ('log', 'sender', $condition);
-} # countlog
-
-1;
use FindBin;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPSFile;
-use MAPSDB;
+use MAPS;
use MAPSLog;
-sub DeliverMail ($$) {
+sub DeliverMail($$) {
my ($userid, $msgfileName) = @_;
# Open maildrop file
# Write msgfile -> $maildrop
print $maildrop "\n\n";
- print $maildrop $_
- while (<$msgfile>);
+ print $maildrop $_ while (<$msgfile>);
# Unlock the file
Unlock $maildrop;
die 'User id not specified' unless $userid;
die 'Msgfile not specified' unless $msgfile;
-my $err = DeliverMail $userid, $msgfile;
+my $err = DeliverMail($userid, $msgfile);
if ($err) {
- OpenDB 'maps', 'spam';
+ OpenDB('maps', 'spam');
- MAPSDB::SetContext $userid;
+ SetContext($userid);
- Error $err;
+ Error($err);
+
+ exit 1;
} # if
-exit $err ? 1 : 0;
+exit 0;
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: MAPSFile.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: File manipulation routines for MAPS.
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPSFile;
-
-use strict;
-use vars qw (@ISA @EXPORT);
-
-use Fcntl ':flock'; # import LOCK_* constants
-
-use Exporter;
-@ISA = qw (Exporter);
-
-@EXPORT = qw (
- Lock
- Unlock
-);
-
-sub Lock {
- my $file = shift;
-
- flock ($file, LOCK_EX);
- # and, in case someone appended while we were waiting...
- seek ($file, 0, 2);
-} # lock
-
-sub Unlock {
- my $file = shift;
- flock ($file,LOCK_UN);
-} # unlock
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-#################################################################################
-#
-# File: $RCSfile: MAPSLog.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: MAPS routines for logging.
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPSLog;
-
-use strict;
-
-use FindBin;
-
-use lib $FindBin::Bin;
-
-use MAPSDB;
-use MAPSUtil;
-use vars qw (@ISA @EXPORT);
-use Exporter;
-
-@ISA = qw (Exporter);
-
-@EXPORT = qw (
- Debug
- Error
- GetStats
- Info
- Logmsg
- countlog
- getstats
- @Types
-);
-
-our @Types = (
- 'returned',
- 'whitelist',
- 'blacklist',
- 'registered',
- 'mailloop',
- 'nulllist'
-);
-
-sub countlog (;$$) {
- my ($condition, $type) = @_;
-
- return MAPSDB::countlog $condition, $type;
-} # countlog
-
-sub nbr_msgs ($) {
- my ($sender) = @_;
-
- return MAPSDB::FindEmail $sender;
-} # nbr_msgs
-
-sub GetStats (;$$) {
- my ($nbr_days, $date) = @_;
-
- $nbr_days ||= 1;
- $date ||= Today2SQLDatetime
-
- my %dates;
-
- while ($nbr_days > 0) {
- my $ymd = substr $date, 0, 10;
- my $sod = $ymd . ' 00:00:00';
- my $eod = $ymd . ' 23:59:59';
-
- my %stats;
-
- foreach (@Types) {
- my $condition = "log.type=\'$_\' and (log.timestamp > \'$sod\' and log.timestamp < \'$eod\')";
- $stats{$_} = countlog $condition, $_;
- } # foreach
-
- $dates{$ymd} = \%stats;
-
- $date = SubtractDays $date, 1;
- $nbr_days--;
- } # while
-
- return %dates
-} # GetStats
-
-sub Logmsg ($$$) {
- my ($type, $sender, $msg) = @_;
-
- AddLog $type, $sender, $msg;
-} # logmsg
-
-sub Debug ($) {
- my ($msg) = @_;
-
- Logmsg 'debug', '', $msg;
-} # Debug
-
-sub Error ($) {
- my ($msg) = @_;
-
- Logmsg 'error', '', $msg;
-} # Error
-
-sub Info ($) {
- my ($msg) = @_;
-
- Logmsg 'info', '', $msg;
-} # info
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: MAPSUtil.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: MAPS Utilities
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPSUtil;
-
-use strict;
-use vars qw (@ISA @EXPORT);
-
-BEGIN {
- $ENV{TZ}='America/Los_Angeles';
-} # BEGIN
-
-@ISA = qw (Exporter);
-
-@EXPORT = qw (
- FormatDate
- FormatTime
- SQLDatetime2UnixDatetime
- SubtractDays
- Today2SQLDatetime
- UnixDatetime2SQLDatetime
-);
-
-sub Today2SQLDatetime;
-
-sub FormatDate {
- my ($date) = @_;
-
- return substr ($date, 5, 2) . '/' .
- substr ($date, 8, 2) . '/' .
- substr ($date, 0, 4);
-} # FormatDate
-
-sub FormatTime {
- my ($time) = @_;
-
- my $hours = substr $time, 0, 2;
-
- $hours = substr $hours, 1, 1 if $hours < 10;
-
- my $minutes = substr $time, 3, 2;
- my $seconds = substr $time, 6, 2;
- my $AmPm = $hours > 12 ? 'Pm' : 'Am';
-
- $hours = $hours - 12 if $hours > 12;
-
- return "$hours:$minutes:$seconds $AmPm";
-} # FormatTime
-
-sub SQLDatetime2UnixDatetime {
- my ($sqldatetime) = @_;
-
- my %months = (
- '01' => 'Jan',
- '02' => 'Feb',
- '03' => 'Mar',
- '04' => 'Apr',
- '05' => 'May',
- '06' => 'Jun',
- '07' => 'Jul',
- '08' => 'Aug',
- '09' => 'Sep',
- '10' => 'Oct',
- '11' => 'Nov',
- '12' => 'Dec',
- );
-
- my $year = substr $sqldatetime, 0, 4;
- my $month = substr $sqldatetime, 5, 2;
- my $day = substr $sqldatetime, 8, 2;
- my $time = FormatTime substr $sqldatetime, 11;
-
- return $months {$month} . " $day, $year \@ $time";
-} # SQLDatetime2UnixDatetime
-
-sub SubtractDays {
- my ($timestamp,$nbr_of_days) = @_;
-
- my @months = (
- 31, # January
- 28, # February
- 31, # March
- 30, # April
- 31, # May
- 30, # June
- 31, # July
- 31, # August
- 30, # September
- 31, # October
- 30, # November
- 31 # Descember
- );
-
- my $year = substr $timestamp, 0, 4;
- my $month = substr $timestamp, 5, 2;
- my $day = substr $timestamp, 8, 2;
-
- # Convert to Julian
- my $days = 0;
- my $m = 1;
-
- for (@months) {
- last if $m >= $month;
- $m++;
- $days += $_;
- } # for
-
- # Subtract $nbr_of_days
- $days += $day - $nbr_of_days;
-
- # Compute $days_in_year
- my $days_in_year;
-
- # Adjust if crossing year boundary
- if ($days <= 0) {
- $year--;
- $days_in_year = (($year % 4) eq 0) ? 366 : 365;
- $days = $days_in_year + $days;
- } else {
- $days_in_year = (($year % 4) eq 0) ? 366 : 365;
- } # if
-
- # Convert back
- $month = 0;
-
- while ($days > 28) {
- # If remaining days is less than the current month then last
- last if ($days <= $months[$month]);
-
- # Subtract off the number of days in this month
- $days -= $months[$month++];
- } # while
-
- # Prefix month with 0 if necessary
- $month++;
- if ($month < 10) {
- $month = '0' . $month;
- } # if
-
- # Prefix days with 0 if necessary
- if ($days == 0) {
- $days = '01';
- } elsif ($days < 10) {
- $days = '0' . $days;
- } # if
-
- return $year . '-' . $month . '-' . $days . substr $timestamp, 10;
-} # SubtractDays
-
-sub UnixDatetime2SQLDatetime {
- my $datetime = shift;
-
- my $orig_datetime = $datetime;
- my %months = (
- 'Jan' => '01',
- 'Feb' => '02',
- 'Mar' => '03',
- 'Apr' => '04',
- 'May' => '05',
- 'Jun' => '06',
- 'Jul' => '07',
- 'Aug' => '08',
- 'Sep' => '09',
- 'Oct' => '10',
- 'Nov' => '11',
- 'Dec' => '12',
- );
-
- # Some mailers neglect to put the leading day of the week field in.
- # Check for this and compensate.
- my $dow = substr $datetime, 0, 3;
-
- if ($dow ne 'Mon' &&
- $dow ne 'Tue' &&
- $dow ne 'Wed' &&
- $dow ne 'Thu' &&
- $dow ne 'Fri' &&
- $dow ne 'Sat' &&
- $dow ne 'Sun') {
- $datetime = 'XXX, ' . $datetime;
- } # if
-
- # Some mailers have day before month. We need to correct this
- my $day = substr $datetime, 5, 2;
-
- if ($day =~ /\d /) {
- $day = '0' . (substr $day, 0, 1);
- $datetime = (substr $datetime, 0, 5) . $day . (substr $datetime, 6);
- } # if
-
- if ($day !~ /\d\d/) {
- $day = substr $datetime, 8, 2;
- } # if
-
- # Check for 1 digit date
- if ((substr $day, 0, 1) eq ' ') {
- $day = '0' . (substr $day, 1, 1);
- $datetime = (substr $datetime, 0, 8) . $day . (substr $datetime, 10);
- } # if
-
- my $year = substr $datetime, 20, 4;
-
- if ($year !~ /\d\d\d\d/) {
- $year = substr $datetime, 12, 4;
- if ($year !~ /\d\d\d\d/) {
- $year = substr $datetime, 12, 2;
- } #if
- } # if
-
- # Check for 2 digit year. Argh!
- if (length $year == 2 or (substr $year, 2, 1) eq ' ') {
- $year = '20' . (substr $year, 0, 2);
- $datetime = (substr $datetime, 0, 12) . '20' . (substr $datetime, 12);
- } # if
-
- my $month_name = substr $datetime, 4, 3;
-
- if (!defined $months {$month_name}) {
- $month_name = substr $datetime, 8, 3;
- } # if
- my $month = $months {$month_name};
-
- my $time = substr $datetime, 11, 8;
-
- if ($time !~ /\d\d:\d\d:\d\d/) {
- $time = substr $datetime, 17, 8
- } # if
-
- if (!defined $year) {
- print "WARNING: Year undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
- if (!defined $month) {
- print "Month undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
- if (!defined $day) {
- print "Day undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
- if (!defined $time) {
- print "Time undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
-
- return "$year-$month-$day $time";
-} # UnixDatetime2SQLDatetime
-
-sub Today2SQLDatetime {
- return UnixDatetime2SQLDatetime scalar localtime;
-} # Today2SQLDatetime
-
-1;
+++ /dev/null
-#################################################################################
-#
-# File: $RCSfile: MAPSWeb.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: Routines for generating portions of MAPSWeb
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPSWeb;
-
-use strict;
-
-use FindBin;
-
-use lib $FindBin::Bin;
-
-use MAPS;
-use MAPSLog;
-use MAPSUtil;
-
-use CGI qw (:standard *table start_Tr end_Tr start_div end_div);
-use vars qw (@ISA @EXPORT);
-
-use Exporter;
-
-@ISA = qw (Exporter);
-
-@EXPORT = qw (
- Debug
- DisplayError
- Footing
- Heading
- NavigationBar
-);
-
-sub getquickstats {
- my $date = shift;
-
- my %dates = GetStats (1, $date);
-
- for (@MAPSLog::Types) {
- $dates{$date}{processed} += $dates{$date}{$_};
- } # foreach
-
- return %dates;
-} # getquickstats
-
-sub displayquickstats {
- # Quick stats are today only.
- my $today = Today2SQLDatetime;
- my $time = substr $today, 11;
- my $date = substr $today, 0, 10;
- my %dates = getquickstats $date;
-
- print start_div {-class => 'quickstats'};
- print h4 {-class => 'header',
- -align => 'center'},
- 'Today\'s Activity';
- print p {-align => 'center'},
- b ('as of ' . FormatTime ($time));
- print start_table {
- -align => 'center',
- -border => 0,
- -cellspacing => 0,
- -cellpadding => 2};
- print start_Tr {-align => 'right'};
- print
- td {-class => 'smalllabel',
- -align => 'right'},
- 'Processed';
- print
- td {-class => 'smallnumber',
- -align => 'right'},
- $dates{$date}{'processed'};
- print
- td {-class => 'smallnumber',
- -align => 'right'},
- 'n/a';
- print end_Tr;
-
- for (@MAPSLog::Types) {
- print start_Tr {-align => 'right'};
-
- my $value = $dates{$date}{$_};
- my $percent;
- if ($_ eq 'mailloop' || $_ eq 'registered') {
- $percent = 'n/a';
- } else {
- $percent = $dates{$date}{processed} == 0 ?
- 0 : $dates{$date}{$_} / $dates{$date}{processed} * 100;
- $percent = sprintf '%5.1f%s', $percent, '%';
- } # if
- my $stat = $value == 0 ?
- 0 : a {-href => "detail.cgi?type=$_;date=$date"}, $value;
- print
- td {-class => 'smalllabel'}, ucfirst ($_);
- print
- td {-class => 'smallnumber'}, $stat;
- print
- td {-class => 'smallnumber'}, $percent;
- print end_Tr;
- } # foreach
- print end_table;
- print end_div;
-} # displayquickstats
-
-sub Footing (;$) {
- my ($table_name) = @_;
-
- # General footing (copyright). Note we calculate the current year
- # so that the copyright automatically extends itself.
- my $year = substr ((scalar (localtime)), 20, 4);
-
- print start_div {-class => "copyright"};
- print "Copyright © 2001-$year - All rights reserved";
- print br (
- a ({-href => 'http://defaria.com'},
- 'Andrew DeFaria'),
- a ({-href => 'mailto:Andrew@DeFaria.com'},
- '<Andrew@DeFaria.com>'));
- print end_div;
-
- print end_div; # This div ends "content" which was started in Heading
- print "<script language='JavaScript1.2'>AdjustTableWidth (\"$table_name\");</script>"
- if $table_name;
- print end_html;
-} # Footing
-
-sub Debug ($) {
- my ($msg) = @_;
-
- print br, font ({ -class => 'error' }, 'DEBUG: '), $msg;
-} # Debug
-
-sub DisplayError ($) {
- my ($errmsg) = @_;
-
- print h3 ({-class => 'error',
- -align => 'center'}, 'ERROR: ' . $errmsg);
-
- Footing;
-
- exit 1;
-} # DisplayError
-
-# This subroutine puts out the header for web pages. It is called by
-# various cgi scripts thus has a few parameters.
-sub Heading ($$$$;$$@) {
- my ($action, # One of getcookie, setcookie, unsetcookie
- $userid, # User id (if setting a cookie)
- $title, # Title string
- $h1, # H1 header
- $h2, # H2 header (optional)
- $table_name, # Name of table in page, if any
- @scripts) = @_; # Array of JavaScript scripts to include
-
- my @java_scripts;
- my $cookie;
-
- # Since CheckAddress appears on all pages (well except for the login
- # page) include it by default along with MAPSUtils.js
- push @java_scripts, [
- {-language => 'JavaScript1.2',
- -src => '/maps/JavaScript/MAPSUtils.js'},
- {-language => 'JavaScript1.2',
- -src => '/maps/JavaScript/CheckAddress.js'}
- ];
-
- # Add on any additional JavaScripts that the caller wants. Note the
- # odd single element array of hashes but that's what CGI requires!
- # Build up scripts from array
- for (@scripts) {
- push @{$java_scripts[0]},
- {-language => 'JavaScript1.2',
- -src => "/maps/JavaScript/$_"}
- } # foreach
-
- # Since Heading is called from various scripts we sometimes need to
- # set a cookie, other times delete a cookie but most times return the
- # cookie.
- if ($action eq 'getcookie') {
- # Get userid from cookie
- $userid = cookie ('MAPSUser');
- } elsif ($action eq 'setcookie') {
- $cookie = cookie (
- -name => 'MAPSUser',
- -value => $userid,
- -expires => '+1y',
- -path => '/maps'
- );
- } elsif ($action eq 'unsetcookie') {
- $cookie = cookie (
- -name => 'MAPSUser',
- -value => '',
- -expires => '-1d',
- -path => '/maps'
- );
- } # if
-
- print
- header (-title => "MAPS: $title",
- -cookie => $cookie);
-
- if (defined $table_name) {
- print
- start_html (-title => "MAPS: $title",
- -author => 'Andrew\@DeFaria.com',
- -style => {-src => '/maps/css/MAPSStyle.css'},
- -onResize => "AdjustTableWidth (\"$table_name\");",
- -head => [
- Link ({-rel => 'icon',
- -href => '/maps/MAPS.png',
- -type => 'image/png'}),
- Link ({-rel => 'shortcut icon',
- -href => '/maps/favicon.ico'})
- ],
- -script => @java_scripts);
- } else {
- print
- start_html (-title => "MAPS: $title",
- -author => 'Andrew\@DeFaria.com',
- -style => {-src => '/maps/css/MAPSStyle.css'},
- -head => [
- Link ({-rel => 'icon',
- -href => '/maps/MAPS.png',
- -type => 'image/png'}),
- Link ({-rel => 'shortcut icon',
- -href => '/maps/favicon.ico'})],
- -script => @java_scripts);
- } # if
-
- print start_div {class => 'heading'};
- print h2 {-align => 'center',
- -class => 'header'},
- font ({-class => 'standout'}, 'MAPS'),
- $h1;
-
- if (defined $h2 && $h2 ne '') {
- print h3 {-align => 'center',
- -class => 'header'},
- $h2;
- } # if
- print end_div;
-
- # Start body content
- print start_div {-class => 'content'};
-
- return $userid
-} # Heading
-
-sub NavigationBar {
- my $userid = shift;
-
- print start_div {-id => 'leftbar'};
-
- if (!defined $userid) {
- print div ({-class => 'username'}, 'Welcome to MAPS');
- print div ({-class => 'menu'},
- (a {-href => '/maps/doc/'},
- 'What is MAPS?<br>'),
- (a {-href => '/maps/doc/SPAM.html'},
- 'What is SPAM?<br>'),
- (a {-href => '/maps/doc/Requirements.html'},
- 'Requirements<br>'),
- (a {-href => '/maps/SignupForm.html'},
- 'Signup<br>'),
- (a {-href => '/maps/doc/Using.html'},
- 'Using MAPS<br>'),
- (a {-href => '/maps/doc/'},
- 'Help<br>'),
- );
- } else {
- print div ({-class => 'username'}, 'Welcome '. ucfirst $userid);
- print div ({-class => 'menu'},
- (a {-href => '/maps/'},
- 'MAPS Home<br>'),
- (a {-href => '/maps/bin/stats.cgi'},
- 'Statistics<br>'),
- (a {-href => '/maps/bin/editprofile.cgi'},
- 'Edit Profile<br>'),
- (a {-href => '/maps/php/Reports.php'},
- 'Reports<br>'),
- (a {-href => '/maps/php/list.php?type=white'},
- 'White List<br>'),
- (a {-href => '/maps/php/list.php?type=black'},
- 'Black List<br>'),
- (a {-href => '/maps/php/list.php?type=null'},
- 'Null List<br>'),
- (a {-href => '/maps/doc/'},
- 'Help<br>'),
- (a {-href => '/maps/adm/'},
- 'MAPS Admin<br>'),
- (a {-href => '/maps/?logout=yes'},
- 'Logout'),
- );
- print start_div {-class => 'search'};
- print start_form {-method => 'get',
- -action => '/maps/bin/search.cgi',
- -name => 'search'};
- print 'Search Sender/Subject',
- textfield {-class => 'searchfield',
- -id => 'searchfield',
- -name => 'str',
- -size => 20,
- -maxlength => 255,
- -value => '',
- -onclick => "document.search.str.value = '';"};
- print end_form;
- print end_div;
-
- displayquickstats;
-
- print start_div {-class => 'search'};
- print start_form {-method => 'post',
- -action => 'javascript://',
- -name => 'address',
- -onsubmit => 'checkaddress(this);'};
- print 'Check Email Address',
- textfield {-class => 'searchfield',
- -id => 'searchfield',
- -name => 'email',
- -size => 20,
- -maxlength => 255,
- -value => '',
- -onclick => "document.address.email.value = '';"};
- print end_form;
- print end_div;
- } # if
-
- print end_div;
-} # NavigationBar
-
-1;
################################################################################
#
# File: $RCSfile: add2blacklist.cgi,v $
-# Revision: $Revision: 1.1 $
+# Revision: $Revision: 1.1 $
# Description: Add an email address to the blacklist
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
my $Userid;
my $type = 'black';
-sub Add2List {
- my $sender = '';
- my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+sub Add2List() {
+ my $sender = '';
+ my $nextseq = GetNextSequenceNo($userid, $type);
while () {
my $pattern = param "pattern$nextseq";
my $comment = param "comment$nextseq";
last if ((!defined $pattern || $pattern eq '') &&
- (!defined $domain || $domain eq ''));
+ (!defined $domain || $domain eq ''));
$sender = lc "$pattern\@$domain";
- my ($status, $rule) = OnBlacklist $sender;
+ my ($status, $rule) = OnBlacklist($sender);
if ($status != 0) {
print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
} else {
- Add2Blacklist $sender, $userid, $comment;
+ Add2Blacklist($sender, $userid, $comment);
print br "The email address, $sender, has been added to ${Userid}'s $type list";
# Now remove this entry from the other lists (if present)
- foreach my $otherlist ('white', 'null') {
- my $sth = FindList $otherlist, $sender;
- my ($sequence, $count);
+ for my $otherlist ('white', 'null') {
+ my $sth = FindList $otherlist, $sender;
+ my ($sequence, $count);
- ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+ ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
- if ($sequence) {
- $count = DeleteList $otherlist, $sequence;
- print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
- if $count > 0;
+ if ($sequence) {
+ $count = DeleteList($otherlist, $sequence);
+ print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $count > 0;
- ResequenceList $userid, $otherlist;
- } # if
- } # foreach
+ ResequenceList($userid, $otherlist);
+ } # if
+ } # for
} # if
$nextseq++;
} # Add2List
# Main
-$userid = Heading (
+$userid = Heading(
'getcookie',
'',
'Add to Black List',
$Userid = ucfirst $userid;
-SetContext $userid;
+SetContext($userid);
-NavigationBar $userid;
+NavigationBar($userid);
Add2List;
};
print '<p></p><center>',
- hidden ({-name => 'type',
- -default => $type}),
- submit ({-name => 'action',
- -value => 'Add New Entry'}),
+ hidden ({-name => 'type',
+ -default => $type}),
+ submit ({-name => 'action',
+ -value => 'Add New Entry'}),
'</center>';
Footing;
################################################################################
#
# File: $RCSfile: add2nulllist.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Add an email address to the nulllist
+# Revision: $Revision: 1.1 $
+# Description: Add an email address to the nulllist
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
# Modified: $Date: 2013/06/12 14:05:47 $
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
my $Userid;
my $type = 'null';
-sub Add2List {
+sub Add2List() {
my $sender = '';
- my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+ my $nextseq = GetNextSequenceNo($userid, $type);
while () {
my $pattern = param "pattern$nextseq";
$sender = lc "$pattern\@$domain";
- my ($status, $rule) = OnNulllist $sender;
+ my ($status, $rule) = OnNulllist($sender);
if ($status != 0) {
print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
} else {
- $hit_count ||= CountMsg $sender;
+ $hit_count ||= CountMsg($sender);
- Add2Nulllist $sender, $userid, $comment, $hit_count;
+ Add2Nulllist($sender, $userid, $comment, $hit_count);
print br "The email address, $sender, has been added to ${Userid}'s $type list";
# Now remove this entry from the other lists (if present)
- foreach my $otherlist ('white', 'black') {
+ for my $otherlist ('white', 'black') {
my $sth = FindList $otherlist, $sender;
my ($sequence, $count);
- ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+ ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
if ($sequence) {
- $count = DeleteList $otherlist, $sequence;
+ $count = DeleteList($otherlist, $sequence);
print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
if $count > 0;
- ResequenceList $userid, $otherlist;
+ ResequenceList($userid, $otherlist);
} # if
- } # foreach
+ } # for
} # if
$nextseq++;
} # Add2List
# Main
-$userid = Heading (
+$userid = Heading(
'getcookie',
'',
'Add to Null List',
'Add to Null List',
);
-SetContext $userid;
+SetContext($userid);
-NavigationBar $userid;
+NavigationBar($userid);
$Userid = ucfirst $userid;
Add2List;
print start_form {
- -method => 'post',
- -action => 'processaction.cgi',
- -name => 'list'
+ -method => 'post',
+ -action => 'processaction.cgi',
+ -name => 'list'
};
print '<p></p><center>',
- hidden ({-name => 'type',
- -default => $type}),
- submit ({-name => 'action',
- -value => 'Add New Entry'}),
+ hidden ({-name => 'type',
+ -default => $type}),
+ submit ({-name => 'action',
+ -value => 'Add New Entry'}),
'</center>';
Footing;
use FindBin;
-use lib $FindBin::Bin, '/opt/clearscm/lib';
+use lib "$FindBin::Bin/../lib", '/opt/clearscm/lib';
use MAPS;
use MAPSLog;
my $Userid;
my $type = "null";
-sub GetItems {
- my $filename = shift;
+sub GetItems($) {
+ my ($filename) = @_;
my @items;
my @fields = split;
my %item;
- my @address = split /\@/, $fields [0];
+ my @address = split /\@/, $fields[0];
$item{pattern} = $address[0];
$item{domain} = $address[1];
return @items;
} # GetItems
-sub Add2List {
+sub Add2List(@) {
my @items = @_;
- my $sender = "";
- my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+ my $sender = '';
+ my $nextseq = GetNextSequenceNo($userid, $type);
- foreach (@items) {
+ for (@items) {
my %item = %{$_};
my $pattern = $item{pattern};
$sender = lc ("$pattern\@$domain");
- if (OnNulllist $sender) {
- display " Already on list";
+ if (OnNulllist($sender)) {
+ display ' Already on list';
} else {
- Add2Nulllist $sender, $userid, $comment, $hit_count;
- display " done";
+ Add2Nulllist($sender, $userid, $comment, $hit_count);
+ display ' done';
# Now remove this entry from the other lists (if present)
- foreach my $otherlist ("white", "black") {
- my $sth = FindList $otherlist, $sender;
+ for my $otherlist ('white', 'black') {
+ my $sth = FindList($otherlist, $sender);
my ($sequence, $count);
- ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+ ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
if ($sequence) {
- $count = DeleteList $otherlist, $sequence;
+ $count = DeleteList($otherlist, $sequence);
} # if
- } # foreach
+ } # for
} # if
+
$nextseq++;
} # while
# Main
my $filename;
-if ($ARGV [0]) {
+if ($ARGV[0]) {
$filename = $ARGV[0];
} else {
error "Must specify a filename of addresses to null list", 1;
} # if
-SetContext $userid;
+SetContext($userid);
$Userid = ucfirst $userid;
-Add2List (GetItems $filename);
+Add2List(GetItems ($filename));
exit;
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
my $Userid;
my $type = 'white';
-sub Add2List {
+sub Add2List() {
my $sender = '';
- my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+ my $nextseq = GetNextSequenceNo($userid, $type);
while () {
my $pattern = param "pattern$nextseq";
$sender = lc "$pattern\@$domain";
- my ($status, $rule) = OnWhitelist $sender, $userid;
+ my ($status, $rule) = OnWhitelist($sender, $userid);
if ($status != 0) {
print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
} else {
- my $messages = Add2Whitelist $sender, $userid, $comment;
+ my $messages = Add2Whitelist($sender, $userid, $comment);
print br "The email address, $sender, has been added to ${Userid}'s $type list";
if ($messages > 0) {
} # if
# Now remove this entry from the other lists (if present)
- foreach my $otherlist ('black', 'null') {
- my $sth = FindList $otherlist, $sender;
+ for my $otherlist ('black', 'null') {
+ my $sth = FindList($otherlist, $sender);
my ($sequence, $count);
- ($_, $_, $_, $_, $_, $sequence) = GetList $sth;
+ ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
if ($sequence) {
- $count = DeleteList $otherlist, $sequence;
+ $count = DeleteList($otherlist, $sequence);
print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
if $count > 0;
- ResequenceList $userid, $otherlist;
+ ResequenceList($userid, $otherlist);
} # if
- } # foreach
+ } # for
} # if
$nextseq++;
} # Add2List
# Main
-$userid = Heading (
+$userid = Heading(
'getcookie',
'',
'Add to White List',
$Userid = ucfirst $userid;
-SetContext $userid;
+SetContext($userid);
-NavigationBar $userid;
+NavigationBar($userid);
Add2List;
################################################################################
#
# File: $RCSfile: checkaddress,v $
-# Revision: $Revision: 1.1 $
+# Revision: $Revision: 1.1 $
# Description: Check an email address
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
use FindBin;
-use lib $FindBin::Bin, '/opt/clearscm/lib';
+use lib "$FindBin::Bin/../lib", '/opt/clearscm/lib';
use MAPS;
use Display;
-error ("Must specify an email address to check", 1)
+error("Must specify an email address to check", 1)
if !$ARGV[0] or $ARGV[0] eq "";
foreach (@ARGV) {
} # unless
if ($domain eq "defaria.com" and $user ne $username) {
- display "Nulllist - $sender is from this domain but is not from $username";
+ display"Nulllist - $sender is from this domain but is not from $username";
next;
} # if
# Finally, we handle return processing
# Check whitelist
- if (OnWhitelist $sender, $username, 0) {
+ if (OnWhitelist($sender, $username, 0)) {
display "Sender $sender would be whitelisted";
- } elsif (OnBlacklist $sender, 0) {
+ } elsif (OnBlacklist($sender, 0)) {
display "Sender $sender would be be blacklisted";
- } elsif (OnNulllist $sender, 0) {
+ } elsif (OnNulllist($sender, 0)) {
display "Sender $sender would be nulllisted"
} else {
display "Sender $sender would be returned"
################################################################################
#
# File: $RCSfile: checkaddress.cgi,v $
-# Revision: $Revision: 1.1 $
+# Revision: $Revision: 1.1 $
# Description: Check an email address
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
-use CGI qw (:standard);
+use CGI qw(:standard);
# Get MAPSUser from cookie
my $userid;
if (param "user") {
- $userid = param "user";
+ $userid = param("user");
} else {
- $userid = cookie ("MAPSUser");
+ $userid = cookie("MAPSUser");
} # if
-my $sender = param ("sender");
+my $sender = param("sender");
-sub Heading {
+sub Heading() {
print
header (-title => "MAPS: Check Address"),
start_html (-title => "MAPS: Check Address",
"MAPS: Checking address $sender";
} # Heading
-sub Body {
+sub Body() {
my ($onlist, $rule);
# Algorithm change: We now first check to see if the sender is not found
# Then we process nulllist people.
#
# Finally, we handle return processing
- ($onlist, $rule) = OnWhitelist $sender, $userid, 0;
+ ($onlist, $rule) = OnWhitelist($sender, $userid, 0);
if ($onlist) {
print div {-align => "center"},
"Messages from", b ($sender), "will be", b ("delivered"), br, hr;
print $rule;
} else {
- ($onlist, $rule) = OnBlacklist $sender, 0;
+ ($onlist, $rule) = OnBlacklist($sender, 0);
if ($onlist) {
print div {-align => "center"},
"Messages from", b ($sender), "will be", b ("blacklisted"), br, hr;
print $rule;
} else {
- ($onlist, $rule) = OnNulllist $sender, 0;
+ ($onlist, $rule) = OnNulllist($sender, 0);
if ($onlist) {
print div {-align => "center"},
} # if
print br div {-align => "center"},
- submit (-name => "submit",
- -value => "Close",
- -onClick => "window.close (self)");
+ submit(-name => "submit",
+ -value => "Close",
+ -onClick => "window.close (self)");
} # Body
-sub Footing {
+sub Footing() {
print end_html;
} # Footing
# Main
-SetContext $userid;
+SetContext($userid);
Heading;
Body;
Footing;
#!/usr/bin/perl
-#################################################################################
+################################################################################
#
# File: $RCSfile: detail.cgi,v $
# Revision: $Revision: 1.1 $
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
use MAPSUtil;
use MAPSWeb;
-use CGI qw (:standard *table start_td end_td start_Tr end_Tr start_div end_div);
+use CGI qw(:standard *table start_td end_td start_Tr end_Tr start_div end_div);
use CGI::Carp 'fatalsToBrowser';
-my $type = param ('type');
-my $next = param ('next');
-my $lines = param ('lines');
-my $date = param ('date');
+my $type = param('type');
+my $next = param('next');
+my $lines = param('lines');
+my $date = param('date');
$date ||= '';
);
sub MakeButtons {
- my $type = shift;
+ my ($type) = @_;
my $prev_button = $prev >= 0 ?
a ({-href => "detail.cgi?type=$type;date=$date;next=$prev",
-action => 'processaction.cgi',
-name => 'detail'
};
- print start_table ({-align => 'center',
- -id => $table_name,
- -border => 0,
- -cellspacing => 0,
- -cellpadding => 0,
- -width => '100%'}) . "\n";
+ print start_table({-align => 'center',
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 0,
+ -width => '100%'}) . "\n";
my $buttons = MakeButtons $type;
];
print end_div;
- foreach my $sender (ReturnSenders $userid, $type, $next, $lines, $date) {
- my @msgs = ReturnMessages $userid, $sender;
+ for my $sender (ReturnSenders($userid, $type, $next, $lines, $date)) {
+ my @msgs = ReturnMessages($userid, $sender);
my @msgs2 = @msgs;
+
my ($onlist, $seq);
+
my $rule = 'none';
my $hit_count = 0;
- ($onlist, $rule, $seq, $hit_count) = OnWhitelist $sender, $userid, 0;
+ ($onlist, $rule, $seq, $hit_count) = OnWhitelist($sender, $userid, 0);
unless ($onlist) {
- ($onlist, $rule, $seq, $hit_count) = OnBlacklist $sender, 0;
+ ($onlist, $rule, $seq, $hit_count) = OnBlacklist($sender, 0);
unless ($onlist) {
- ($onlist, $rule, $seq, $hit_count) = OnNulllist $sender, 0;
+ ($onlist, $rule, $seq, $hit_count) = OnNulllist($sender, 0);
} # unless
} # unless
-border => 0,
-width => '100%',
-bgcolor => '#d4d0c8'};
+
+ # Get subject line
+ my $heading = $msgs2[0][0] || '';
+ $heading = "?subject=$heading" if $heading;
print
td {-class => 'tablelabel',
-valign => 'middle',
td {-class => 'sender',
-valign => 'middle',
-width => '40%'},
- a {-href => "mailto:$sender?subject=$msgs2[0][0]"}, $sender,
+ a {-href => "mailto:$sender$heading"}, $sender,
td {
-valign => 'middle'},
$rule;
my $messages = 1;
- foreach (@msgs) {
+ for (@msgs) {
my $msg_date = pop @{$_};
my $subject = pop @{$_};
-valign => 'middle'}, $msg_date
];
print end_table;
- } # foreach
+ } # for
print end_td;
print end_Tr;
- } # foreach
+ } # for
print start_div {-class => 'toolbar'};
print
print end_div;
print end_table;
print end_form;
+
+ return;
} # PrintTable
# Main
my $heading_date =$date ne '' ? ' on ' . FormatDate ($date) : '';
-$userid = Heading (
+$userid = Heading(
'getcookie',
'',
(ucfirst ($type) . ' Report'),
$userid ||= $ENV{USER};
-SetContext $userid;
-NavigationBar $userid;
+SetContext($userid);
+NavigationBar($userid);
unless ($lines) {
- my %options = GetUserOptions $userid;
+ my %options = GetUserOptions($userid);
$lines = $options{'Page'};
} # unless
. "and timestamp > '$sod' and timestamp < '$eod' ";
} # if
-$total = MAPSDB::count_distinct ('log', 'sender', $condition);
+$total = count_distinct('log', 'sender', $condition);
$next ||= 0;
if (($next - $lines) > 0) {
$prev = $next - $lines;
} else {
- $prev = $next eq 0 ? -1 : 0;
+ $prev = $next == 0 ? -1 : 0;
} # if
-PrintTable $type;
+PrintTable($type);
-Footing $table_name;
+Footing($table_name);
exit;
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
my $msg_nbr = param('msg_nbr');
my $table_name = 'message';
-sub ParseEmail (@) {
+sub ParseEmail(@) {
my (@header) = @_;
my %header;
# First output the header information. Note we'll skip uninteresting stuff
- foreach (@header) {
+ for (@header) {
last if ($_ eq '' || $_ eq "\cM");
# Escape "<" and ">"
} elsif (/^Content-Transfer-Encoding: base64/) {
$header{base64} = 1;
} # if
- } # while
+ } # for
return %header;
} # ParseEmail
-sub Body ($) {
+sub Body($) {
my ($count) = @_;
$count ||= 1;
($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle;
} # for
- my $parser = new MIME::Parser;
+ my $parser = MIME::Parser->new();
$parser->output_to_core (1);
print '</pre>';
} # if
} else {
- foreach my $part ($entity->parts) {
+ for my $part ($entity->parts) {
# We assume here that if this part is multipart/alternative then
# there exists at least one part that is text/html and we favor
# that (since we're outputing to a web page anyway...
if ($part->mime_type eq 'multipart/alternative') {
- foreach my $subpart ($part->parts) {
+ for my $subpart ($part->parts) {
if ($subpart->mime_type eq 'text/html') {
# There should be an easier way to get this but I couldn't find one.
my $encoding = ${$subpart->{mail_inet_head}{mail_hdr_hash}{'Content-Transfer-Encoding'}[0]};
$subpart->print_body;
last;
} # if
- } # foreach
+ } # for
} else {
if ($part->mime_type =~ /text/) {
- my $encoding = ${$part->{mail_inet_head}{mail_hdr_hash}{'Content-Transfer-Encoding'}[0]};
+ my $encoding = '';
+
+ $encoding = ${$part->{mail_inet_head}{mail_hdr_hash}{'Content-Transfer-Encoding'}[0]}
+ if $part->{mail_inet_head}{mail_hdr_hash}{'Content-Transfer-Encoding'};
+
if ($encoding =~ /base64/) {
$part->bodyhandle->print();
} else {
} # if
} # if
} # if
- } # foreach
+ } # for
} # if
print "</td></tr>\n";
print end_table;
} # Body
-$userid = Heading (
+$userid = Heading(
'getcookie',
'',
"Email message from $sender",
$table_name,
);
-SetContext $userid;
-NavigationBar $userid;
+SetContext($userid);
+NavigationBar($userid);
-Body $msg_nbr;
+Body($msg_nbr);
-Footing $table_name;
+Footing($table_name);
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: domains,v $
-# Revision: $Revision: 1.1 $
-# Description: Display entries from the list table where there is at least one
-# entry with a null pattern (nuke the domain) and yet still other
-# entries with the same domain name but having a pattern. We may
-# want to eliminate the other entries since we're nuking the
-# whole domain anyway.
-# Author: Andrew@DeFaria.com
-# Created: Sat Oct 20 23:28:19 MST 2007
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: Perl
-#
-# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-use strict;
-use warnings;
-
-use FindBin;
-use Getopt::Long;
-
-use lib $FindBin::Bin, '/opt/clearscm/lib';
-
-use MAPS;
-use MAPSDB;
-
-use Display;
-
-sub Usage () {
- display <<END;
-$FindBin::Script { -verbose } { -debug } { -usage }
-END
-
- exit 1;
-} # Usage
-
-GetOptions (
- "verbose" => sub { set_verbose },
- "debug" => sub { set_debug },
- "usage" => sub { Usage },
-) || Usage;
-
-my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
-
-# Main
-SetContext $userid;
-
-my $statement = "select domain from list where userid=\"$userid\" and type=\"null\" and pattern is null";
-
-my $need_requence = 0;
-
-foreach my $domain (sort (&MAPSDB::GetRows ($statement))) {
- verbose "Processing domain $domain";
- $statement = "select sequence from list where userid = \"$userid\" and domain = \"$domain\" and type = \"null\" and pattern is not null";
-
- foreach my $sequence (MAPSDB::GetRows $statement) {
- display "Deleting $domain ($sequence)";
- $need_requence = 1;
- DeleteList "null", $sequence;
- } # foreach
-} # foreach
-
-if ($need_requence) {
- verbose "Resequencing null list...";
- ResequenceList $userid, "null";
- verbose "done";
-} # if
-
-exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: domains,v $
+# Revision: $Revision: 1.1 $
+# Description: Display entries from the list table where there is at least one
+# entry with a null pattern (nuke the domain) and yet still other
+# entries with the same domain name but having a pattern. We may
+# want to eliminate the other entries since we're nuking the
+# whole domain anyway.
+# Author: Andrew@DeFaria.com
+# Created: Sat Oct 20 23:28:19 MST 2007
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: Perl
+#
+# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+use Getopt::Long;
+
+use lib "$FindBin::Bin/../lib", '/opt/clearscm/lib';
+
+use MAPS;
+use Display;
+
+sub Usage () {
+ display <<END;
+$FindBin::Script { -verbose } { -debug } { -usage }
+END
+
+ exit 1;
+} # Usage
+
+GetOptions (
+ "verbose" => sub { set_verbose },
+ "debug" => sub { set_debug },
+ "usage" => sub { Usage },
+) || Usage;
+
+my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
+
+# Main
+SetContext $userid;
+
+my $statement = "select domain from list where userid=\"$userid\" and type=\"null\" and pattern is null";
+
+my $need_resequence = 0;
+
+for my $domain (sort (GetRows($statement))) {
+ verbose "Processing domain $domain";
+ $statement = "select sequence from list where userid = \"$userid\" and domain = \"$domain\" and type = \"null\" and pattern is not null";
+
+ for my $sequence (GetRows $statement) {
+ display "Deleting $domain ($sequence)";
+ $need_resequence = 1;
+ DeleteList "null", $sequence;
+ } # for
+} # for
+
+if ($need_resequence) {
+ verbose "Resequencing null list...";
+ ResequenceList $userid, "null";
+ verbose "done";
+} # if
+
+exit;
################################################################################
#
# File: $RCSfile: editprofile.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Edit the user's profile
+# Revision: $Revision: 1.1 $
+# Description: Edit the user's profile
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
# Modified: $Date: 2013/06/12 14:05:47 $
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
-use CGI qw (:standard *table);
+use CGI qw(:standard *table);
my $userid;
-my $table_name = "profile";
+my $table_name = 'profile';
-sub Body {
- my $handle = FindUser $userid;
+sub Body() {
+ my $handle = FindUser($userid);
my ($fullname, $email, $password);
- ($_, $fullname, $email, $password) = GetUser ($handle);
+ ($_, $fullname, $email, $password) = GetUser($handle);
$handle->finish;
- my %options = GetUserOptions $userid;
+ my %options = GetUserOptions($userid);
print start_form {
- -method => "post",
- -action => "updateprofile.cgi",
- -onSubmit => "return validate (this);"
+ -method => 'post',
+ -action => 'updateprofile.cgi',
+ -onSubmit => 'return validate (this);'
};
print start_table {
- -align => "center",
- -id => $table_name,
- -border => 1,
- -cellspacing => 0,
- -cellpadding => 2,
- -width => "100%"};
+ -align => 'center',
+ -id => $table_name,
+ -border => 1,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -width => '100%'};
print Tr ([
- td {-class => "label",
- -width => 134},
- "Username:",
- td {-width => 290},
- $userid,
- td {-class => "notetext"},
- "Specify a username to log into MAPS"
+ td {-class => 'label',
+ -width => 134}, 'Username:',
+ td {-width => 290}, $userid,
+ td {-class => 'notetext'}, 'Specify a username to log into MAPS'
]) . "\n";
print Tr ([
- td {-class => "label"},
- "Full name:",
+ td {-class => 'label'}, 'Full name:',
td (
- textfield {-class => "inputfield",
- -size => 50,
- -name => "fullname",
- -value => "$fullname"}),
- td {-class => "notetext"},
- "Specify your full name"
+ textfield {-class => 'inputfield',
+ -size => 50,
+ -name => 'fullname',
+ -value => $fullname}),
+ td {-class => 'notetext'},'Specify your full name'
]) . "\n";
print Tr [
- td {-class => "label"},
- "Email:",
+ td {-class => 'label'}, 'Email:',
td (
- textfield {-class => "inputfield",
- -size => 50,
- -name => "email",
- -value => $email}),
- td {-class => "notetext"},
- "Your email address is used if you are a " .
+ textfield {-class => 'inputfield',
+ -size => 50,
+ -name => 'email',
+ -value => $email}),
+ td {-class => 'notetext'},'Your email address is used if you are a ' .
i ("Tag & Forward") .
- " user. This is the email address that MAPS will forward your email to after it tags it. This email address is also used in case you forget your password so that we can email you your password."
+ ' user. This is the email address that MAPS will forward your email to after it tags it. This email address is also used in case you forget your password so that we can email you your password.'
];
print Tr [
- td {-class => "label"},
- "Old Password:",
+ td {-class => 'label'}, 'Old Password:',
td (
- password_field {-class => "inputfield",
- -size => 20,
- -name => "old_password"}),
- td {-class => "notetext"},
- "Enter your old password"
+ password_field {-class => 'inputfield',
+ -size => 20,
+ -name => 'old_password'}),
+ td {-class => 'notetext'}, 'Enter your old password'
];
print Tr [
- td {-class => "label"},
- "New Password:",
+ td {-class => 'label'}, 'New Password:',
td (
- password_field {-class => "inputfield",
- -size => 20,
- -name => "new_password",
- -value => ""}),
- td {-class => "notetext"},
- "Choose a new password greater than 6 characters."
+ password_field {-class => 'inputfield',
+ -size => 20,
+ -name => 'new_password',
+ -value => ''}),
+ td {-class => 'notetext'}, 'Choose a new password greater than 6 characters.'
];
print Tr [
- td {-class => "label"},
- "Repeat Password:",
+ td {-class => 'label'},'Repeat Password:',
td (
- password_field {-class => "inputfield",
- -size => 20,
- -name => "repeated_password",
- -value => ""}),
- td {-class => "notetext"},
- "Re-enter your password so we can be sure you typed it correctly."
+ password_field {-class => 'inputfield',
+ -size => 20,
+ -name => 'repeated_password',
+ -value => ''}),
+ td {-class => 'notetext'}, 'Re-enter your password so we can be sure you typed it correctly.'
];
print Tr [
- td {-class => "label"},
- "MAPSPOP user:",
+ td {-class => 'label'}, 'MAPSPOP user:',
td (
- font ({-class => "label"},
- radio_group {-name => "MAPSPOP",
- -values => ["yes", "no"],
- -default => "no",
- -labels => {"yes" => "Yes",
- "no" => "No"}})),
- td {-class => "notetext"},
- "MAPSPOP users need to download " .
- a ({-href => "/maps/bin/MAPSPOP.exe"}, "MAPSPOP") .
- ". See " .
- a ({-href => "/maps/doc/UsingMAPSPOP.html"}, "Using MAPSPOP") .
- " for more information."
+ font ({-class => 'label'},
+ radio_group {-name => 'MAPSPOP',
+ -values => ['yes', 'no'],
+ -default => 'no',
+ -labels => {'yes' => 'Yes',
+ 'no' => 'No'}})),
+ td {-class => 'notetext'}, 'MAPSPOP users need to download ' .
+ a ({-href => '/maps/bin/MAPSPOP.exe'}, 'MAPSPOP') .
+ '. See ' .
+ a ({-href => '/maps/doc/UsingMAPSPOP.html'}, 'Using MAPSPOP') .
+ ' for more information.'
];
print Tr [
- td {-class => "label"},
- "Keep history for:",
+ td {-class => 'label'}, 'Keep history for:',
td (
- font ({-class => "label"},
- popup_menu {-class => "inputfield",
- -name => "history",
- -values => ["7", "14", "30", "60", "90"],
- -default => $options{"History"}}),
- font ({-class => "label"}, " days")),
- td {-class => "notetext"},
- "This specifies how many days of history that MAPS will keep before discarding returned messages."
+ font ({-class => 'label'},
+ popup_menu {-class => 'inputfield',
+ -name => 'history',
+ -values => ['7', '14', '30', '60', '90'],
+ -default => $options{'History'}}),
+ font ({-class => 'label'}, ' days')),
+ td {-class => 'notetext'}, 'This specifies how many days of history that MAPS will keep before discarding returned messages.'
];
print Tr [
- td {-class => "label"},
- "Dates in Stats Page:",
+ td {-class => 'label'}, 'Dates in Stats Page:',
td (
- font ({-class => "label"},
- popup_menu {-class => "inputfield",
- -name => "dates",
- -values => ["7", "14", "21", "30"],
- -default => $options{"Dates"}})),
- td {-class => "notetext"},
- "This specifies how many days are displayed in the MAPS Stats Page."
+ font ({-class => 'label'},
+ popup_menu {-class => 'inputfield',
+ -name => 'dates',
+ -values => ['7', '14', '21', '30'],
+ -default => $options{'Dates'}})),
+ td {-class => 'notetext'}, 'This specifies how many days are displayed in the MAPS Stats Page.'
];
print Tr [
- td {-class => "label"},
- "Entries per page:",
+ td {-class => 'label'}, 'Entries per page:',
td (
- font ({-class => "label"},
- popup_menu {-class => "inputfield",
- -name => "days",
- -values => ["10", "20", "30", "40", "50"],
- -default => $options{"Page"}})),
- td {-class => "notetext"},
- "This specifies how many entries are displayed per page in the online MAPS Reports."
+ font ({-class => 'label'},
+ popup_menu {-class => 'inputfield',
+ -name => 'days',
+ -values => ['10', '20', '30', '40', '50'],
+ -default => $options{'Page'}})),
+ td {-class => 'notetext'}, 'This specifies how many entries are displayed per page in the online MAPS Reports.'
];
print Tr [
- td {-class => "label"},
- i ("Tag & Forward:"),
+ td {-class => 'label'}, i ('Tag & Forward:'),
td (
- font ({-class => "label"},
- radio_group {-name => "tag_and_forward",
- -values => ["yes", "no"],
- -default => "no",
- -labels => {"yes" => "Yes",
- "no" => "No"}})),
- td {-class => "notetext"},
- i ("Tag and Forward") .
- " means that MAPS will not filter or save any email for you. Instead it will simply add an X-MAPS header to your email indicating what MAPS would have done with the email. This allows you to filter your email in your local email client."
+ font ({-class => 'label'},
+ radio_group {-name => 'tag_and_forward',
+ -values => ['yes', 'no'],
+ -default => 'no',
+ -labels => {'yes' => 'Yes',
+ 'no' => 'No'}})),
+ td {-class => 'notetext'},
+ i ('Tag and Forward') . ' means that MAPS will not filter or save any email for you. Instead it will simply add an X-MAPS header to your email indicating what MAPS would have done with the email. This allows you to filter your email in your local email client.'
];
print end_table;
- print br (div {-align => "center"},
- submit (-name => "submit",
- -value => "Update Profile"));
+ print br (div {-align => 'center'},
+ submit (-name => 'submit',
+ -value => 'Update Profile'));
print end_form;
} # Body
# Main
-my @scripts = ("MAPSUtils.js", "CheckEditProfile.js");
-
-$userid = Heading (
- "getcookie",
- "",
- "Edit Profile",
- "Spam Elimination System",
- "",
+my @scripts = ('MAPSUtils.js', 'CheckEditProfile.js');
+
+$userid = Heading(
+ 'getcookie',
+ '',
+ 'Edit Profile',
+ 'Spam Elimination System',
+ '',
$table_name,
@scripts
);
use FindBin;
local $0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
use CGI qw/:standard *table/;
use CGI::Carp "fatalsToBrowser";
-my $type = param ("type");
-my $userid = cookie ("MAPSUser");
+my $type = param('type');
+my $userid = cookie("MAPSUser");
$userid //= $ENV{USER};
-my $Userid = ucfirst $userid;
+my $Userid = ucfirst $userid;
-sub PrintList {
- my $type = shift;
+sub PrintList($) {
+ my ($type) = @_;
- my $year = substr ((scalar (localtime)), 20, 4);
+ my $year = substr((scalar(localtime)), 20, 4);
my ($pattern, $domain, $comment, $hit_count, $last_hit);
- my $sth = FindList $type;
+ my $sth = FindList($type);
print "\################################################################################\n";
print "\#\n";
print "\#\n";
print "\################################################################################\n";
- while (($_, $_, $pattern, $domain, $comment, $_, $hit_count, $last_hit) = GetList $sth) {
+ while (($_, $_, $pattern, $domain, $comment, $_, $hit_count, $last_hit) = GetList($sth)) {
last if !(defined $pattern or defined $domain);
$pattern //= '';
} # PrintList
# Main
-SetContext $userid;
+SetContext($userid);
-print header (
+print header(
-type => "application/octet-stream",
-attachment => "$type.list",
);
-PrintList $type;
+PrintList($type);
exit;
use FindBin;
local $0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use Getopt::Long;
use Pod::Usage;
use CGI qw/:standard *table/;
use CGI::Carp "fatalsToBrowser";
-my $type = param('type');
my $userid = cookie('MAPSUser');
$userid //= $ENV{USER};
my $Userid = ucfirst $userid;
my %opts = (
usage => sub { pod2usage },
help => sub { pod2usage (-verbose => 2)},
+ type => param('type'),
file => param('file'),
);
my $alreadyExists;
if ($type eq 'white') {
- $alreadyExists = OnWhitelist $pattern, $userid;
+ ($alreadyExists) = OnWhitelist($pattern, $userid);
} elsif ($type eq 'black') {
- $alreadyExists = OnBlacklist $pattern, $userid;
+ ($alreadyExists) = OnBlacklist($pattern, $userid);
} elsif ($type eq 'null') {
- $alreadyExists = OnNulllist $pattern, $userid;
+ ($alreadyExists) = OnNulllist($pattern, $userid);
} # if
unless ($alreadyExists) {
- AddList ($type, $pattern, 0, $comment, $hit_count, $last_hit);
+ AddList($type, $pattern, 0, $comment, $hit_count, $last_hit);
$count++;
+ } else {
+ print br "$pattern is already on your " . ucfirst($type) . 'list';
} # unless
} # while
} # importList
# Main
-GetOptions (
+GetOptions(
\%opts,
'usage',
'help',
'verbose',
'debug',
'file=s',
+ 'type=s',
);
-pod2usage "Type not specified" unless $type;
+pod2usage "Type not specified" unless $opts{type};
pod2usage '-file should be specified' unless $opts{file};
pod2usage "Unable to read $opts{file}" unless -r $opts{file};
-$userid = Heading (
+$userid = Heading(
'getcookie',
'',
'Import List',
'Import List',
);
-SetContext $userid;
+SetContext($userid);
-NavigationBar $userid;
+NavigationBar($userid);
-my $count = importList $type;
+my $count = importList($opts{type});
if ($count == 1) {
print br "$count list entry imported";
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: list.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Manage lists
-# Author: Andrew@DeFaria.com
-# Created: Mon Jan 16 20:25:32 PST 2006
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-use strict;
-use warnings;
-
-use FindBin;
-
-local $0 = $FindBin::Script;
-
-use lib $FindBin::Bin;
-
-use MAPS;
-use MAPSLog;
-use MAPSUtil;
-use MAPSWeb;
-use CGI qw (:standard *table start_div end_div);
-use CGI::Carp "fatalsToBrowser";
-
-my $next = param("next");
-my $lines = param("lines");
-my $type = param("type");
-my $message = param("message");
-my $Type = ucfirst $type;
-my $userid;
-my $prev;
-my $total;
-my $last;
-my $table_name = "list";
-
-sub Body {
- my $type = shift;
-
- if (defined $message) {
- print div {-align => "center"},
- font {-class => "error"}, $message;
- } # if
-
- print start_form {
- -method => "post",
- -action => "processaction.cgi",
- -name => "list"
- };
-
- # Print some hidden fields to pass along
- print
- hidden (-name => "type",
- -default => $type),
- hidden (-name => "next",
- -default => $next);
-
- my $current = $next + 1;
-
- print div {-align => "center"}, b (
- "(" . $current . "-" . $last . " of " . $total . ")");
- print start_div {-class => "toolbar",
- -align => "center"};
- my $prev_button = $prev >= 0 ?
- a ({-href => "list.cgi?type=$type;next=$prev",
- -accesskey => 'p',
- }, "<img src=/maps/images/previous.gif border=0 alt=Previous align=middle>") : "";
- my $next_button = ($next + $lines) < $total ?
- a {-href => "list.cgi?type=$type;next=" . ($next + $lines),
- -accesskey => 'n',
- }, "<img src=/maps/images/next.gif border=0 alt=Next align=middle>" : "";
- print $prev_button,
- submit ({-name => "action",
- -value => "Add New Entry",
- -onClick => "return NoneChecked (document.list);"}),
- submit ({-name => "action",
- -value => "Delete Marked",
- -onClick => "return CheckAtLeast1Checked (document.list) && AreYouSure ('Are you sure you want to delete these entries?');"}),
- submit ({-name => "action",
- -value => "Modify Marked",
- -onClick => "return CheckAtLeast1Checked (document.list);"}),
- submit ({-name => "action",
- -value => "Reset Marks",
- -onClick => "return ClearAll (document.list);"}),
- $next_button;
- print end_div;
- print start_table {-align => "center",
- -id => $table_name,
- -border => 0,
- -cellspacing => 0,
- -cellpadding => 4,
- -width => "100%"};
- print Tr [
- th {-class => "tableleftend"}, "Seq",
- th {-class => "tableheader"}, "Mark",
- th {-class => "tableheader"}, "Username",
- th {-class => "tableheader"}, "@",
- th {-class => "tableheader"}, "Domain",
- th {-class => "tablerightend"}, "Comments"
- ];
-
- my @list = ReturnList $type, $next, $lines;
- my %record;
- my $i = 1;
-
- foreach (@list) {
- %record = %{$_};
- $record{pattern} = " " if !defined $record{pattern};
- $record{domain} = " " if !defined $record{domain};
- $record{comment} = " " if !defined $record{comment};
-
- my $leftclass = ($i eq $lines || $record{sequence} eq $total) ?
- "tablebottomleft" : "tableleftdata";
- my $dataclass = ($i eq $lines || $record{sequence} eq $total) ?
- "tablebottomdata" : "tabledata";
- my $rightclass = ($i eq $lines || $record{sequence} eq $total) ?
- "tablebottomright" : "tablerightdata";
- $i++;
-
- print Tr [
- td {-class => $leftclass,
- -align => "center"}, $record{sequence},
- td {-class => $dataclass,
- -align => "center"},
- checkbox ({-name => "action$record{sequence}",
- -label => ""}),
- td {-class => $dataclass,
- -align => "right"}, $record{pattern},
- td {-class => $dataclass,
- -align => "center"}, "\@",
- td {-class => $dataclass,
- -align => "left"}, $record{domain},
- td {-class => $rightclass,
- -align => "left"}, $record{comment}
- ];
- } # foreach
- print end_table;
- print end_form;
-
- print div ({-align => "center"},
- a ({-href => "/maps/bin/exportlist.cgi?type=$type"},
- submit ({-name => "export",
- -value => "Export List"})),
- a ({-href => "/maps/bin/importlist.cgi?type=$type"},
- submit ({-name => "import",
- -value => "Import List"})));
-
- return;
-} # Body
-
-# Main
-my @scripts = ("ListActions.js");
-
-$userid = Heading (
- "getcookie",
- "",
- "Manage $Type List",
- "Manage $Type List",
- "",
- $table_name,
- @scripts
-);
-
-SetContext $userid;
-NavigationBar $userid;
-
-if (!defined $lines) {
- my %options = GetUserOptions $userid;
- $lines = $options{"Page"};
-} # if
-
-$total = MAPSDB::count "list", "userid = \"$userid\" and type = \"$type\"";;
-
-$next = !defined $next ? 0 : $next;
-$last = $next + $lines < $total ? $next + $lines : $total;
-
-if (($next - $lines) > 0) {
- $prev = $next - $lines;
-} else {
- $prev = $next == 0 ? -1 : 0;
-} # if
-
-Body $type;
-Footing $table_name;
-
-exit;
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: main.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: This is the main or home page for maps. It is presented when the
-# user logs in.
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-use strict;
-use warnings;
-
-use FindBin;
-$0 = $FindBin::Script;
-
-use lib $FindBin::Bin;
-
-use MAPS;
-use MAPSLog;
-use MAPSUtil;
-use MAPSWeb;
-
-use CGI qw (:standard *table start_Tr end_Tr start_div end_div);
-use CGI::Carp "fatalsToBrowser";
-
-my $new_userid = param ("userid");
-my $password = param ("password");
-
-sub Body {
- print
- h3 ("Welcome to MAPS!"),
- p "This is the main or home page of MAPS. To the left
- you see a menu of choices that you can use to explore MAPS
- functionality.",
- a ({-href => "/maps/bin/stats.cgi"},
- "Statistics"),
- "gives you a view of the spam that MAPS has been trapping for you
- in tabular format. You can use",
- a ({-href => "/maps/bin/editprofile.cgi"},
- "Edit Profile"),
- "to change your profile information or to change your password.";
- print
- p "MAPS also offers a series of web based",
- a ({-href => "/maps/Reports.html"},
- "Reports"),
- "to analyze your mail flow. You can manage your",
- a ({-href => "/maps/bin/list.cgi?type=white"},
- "White") . ",",
- a ({-href => "/maps/bin/list.cgi?type=black"},
- "Black"), "and",
- a ({-href => "/maps/bin/list.cgi?type=null"},
- "Null"),
- "lists although MAPS seeks to put that responsibility on those
- who wish to email you. You can use this to pre-register somebody
- or to black or null list somebody. You can also import/export
- your lists through these pages.";
- print
- p a ({-href => "/maps/Admin.html"},
- "MAPS Administration"),
- "is to administer MAPS itself and is only available to MAPS
- Administrators.";
- print
- p "Also on the left you will see ", i ("Today's Activity"),
- "which quickly shows you what mail MAPS processed today for you.";
-} # Body
-
-# Main
-my $action;
-
-if (defined $new_userid) {
- my $result = Login $new_userid, $password;
-
- if ($result == -1) {
- if ($new_userid eq "") {
- print redirect ("/maps/?errormsg=Please specify a username");
- exit $result;
- } else {
- print redirect ("/maps/?errormsg=User \"$new_userid\" does not exist");
- exit $result;
- } # if
- } elsif ($result == -2) {
- print redirect ("/maps/?errormsg=Invalid password");
- exit $result;
- } else {
- $action = "setcookie";
- } # if
-} else {
- $action = "getcookie"
-} # if
-
-my $userid = Heading (
- $action,
- $new_userid,
- "Home",
- "Spam Elimination System"
-);
-
-SetContext $userid;
-NavigationBar $userid;
-Body;
-Footing;
-
-exit;
use File::Temp qw (tempfile);
use Net::Domain qw (hostdomain);
-use lib $FindBin::Bin, '/opt/clearscm/lib';
+use lib "$FindBin::Bin/../lib", '/opt/clearscm/lib';
use MAPS;
use MAPSLog;
################################################################################
#
# File: $RCSfile: mapsscrub,v $
-# Revision: $Revision: 1.1 $
+# Revision: $Revision: 1.1 $
# Description: This script scrubs messages from the MAPS database based on the
-# users settings.
+# users settings.
# Author: Andrew@DeFaria.com
# Created: Fri Nov 29 14:17:21 2002
# Modified: $Date: 2013/06/12 14:05:47 $
use FindBin;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSUtil;
my $userid;
-my $verbose = defined $ARGV[0] && $ARGV[0] eq "-v" ? 1 : 0;
-my $total_emails = 0;
-my $total_log_entries = 0;
-my $total_list_entries = 0;
-my $total_users_emails = 0;
+my $verbose = defined $ARGV[0] && $ARGV[0] eq "-v" ? 1 : 0;
+my $total_emails = 0;
+my $total_log_entries = 0;
+my $total_list_entries = 0;
+my $total_users_emails = 0;
my ($history, $nbr_emails, $nbr_log_entries, $nbr_list_entries, $users_emails);
----------------- --- ------ ------ ------ -------------
.
-sub verbose {
- my $msg = shift;
+sub verbose($) {
+ my ($msg) = @_;
- return if $verbose eq 0;
+ return if $verbose == 0;
print "$msg\n";
} # verbose
-sub CleanUp {
- my $userid = shift;
+sub CleanUp($) {
+ my ($userid) = @_;
+
+ my %options = GetUserOptions($userid);
- my %options = GetUserOptions $userid;
$history = $options{"History"};
- my $timestamp = SubtractDays (Today2SQLDatetime, $history);
- $nbr_emails = CleanEmail $timestamp;
- $nbr_log_entries = CleanLog $timestamp;
- $nbr_list_entries = CleanList $timestamp, "null";
- $users_emails = MAPSDB::count ("email", "userid = \"$userid\"");
+ my $timestamp = SubtractDays(Today2SQLDatetime, $history);
+
+ $nbr_emails = CleanEmail $timestamp;
+ $nbr_log_entries = CleanLog $timestamp;
+ $nbr_list_entries = CleanList $timestamp, "null";
+ $users_emails = count("email", "userid = \"$userid\"");
+
write () if $verbose;
return ($nbr_emails, $nbr_log_entries, $nbr_list_entries, $users_emails);
#$~ = "REPORT" if $verbose;
-while (($userid) = GetUser $handle) {
- last if !defined $userid;
- SetContext $userid;
- my ($emails, $log_entries, $list_entries, $users_emails) = CleanUp $userid;
- $total_emails += $emails;
- $total_log_entries += $log_entries;
- $total_list_entries += $list_entries;
- $total_users_emails += $users_emails;
+while (($userid) = GetUser($handle)) {
+ last unless $userid;
+
+ SetContext($userid);
+
+ my ($emails, $log_entries, $list_entries, $users_emails) = CleanUp($userid);
+
+ $total_emails += $emails;
+ $total_log_entries += $log_entries;
+ $total_list_entries += $list_entries;
+ $total_users_emails += $users_emails;
} # while
$handle->finish;
if ($verbose) {
- $userid = "Total:";
- $history = "n/a";
- $nbr_emails = $total_emails;
- $nbr_log_entries = $total_log_entries;
- $nbr_list_entries = $total_list_entries;
- $users_emails = $total_users_emails;
- write ();
+ $userid = "Total:";
+ $history = "n/a";
+ $nbr_emails = $total_emails;
+ $nbr_log_entries = $total_log_entries;
+ $nbr_list_entries = $total_list_entries;
+ $users_emails = $total_users_emails;
+ write();
} # if
# Now optimize the database
+++ /dev/null
-#!/usr/bin/perl
-#################################################################################
-# File: $RCSfile: mapsutil,v $
-# Revision: $Revision: 1.1 $
-# Description: This script implements a small command interpreter to exercise
-# MAPS functions.
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################use strict;
-use warnings;
-
-use FindBin;
-
-use lib $FindBin::Bin;
-
-use MAPS;
-use MAPSLog;
-use Term::ReadLine;
-use Term::ReadLine::Gnu;
-use Term::ReadKey;
-
-sub EncryptPassword {
- my $password = shift;
- my $userid = shift;
-
- my $encrypted_password = Encrypt $password, $userid;
-
- print "Password: $password = $encrypted_password\n";
-} # EncryptPassword
-
-sub DecryptPassword {
- my $password = shift;
- my $userid = shift;
-
- my $decrypted_password = Decrypt $password, $userid;
-
- print "Password: $password = $decrypted_password\n";
-} # DecryptPassword
-
-sub Resequence {
- my $userid = shift;
- my $type = shift;
-
- ResequenceList $userid, $type;
-} # Resequence
-
-sub GetPassword {
- print "Password:";
- ReadMode "noecho";
- my $password = ReadLine (0);
- chomp $password;
- print "\n";
- ReadMode "normal";
-
- return $password
-} # GetPassword
-
-sub Login2MAPS {
- my $username = shift;
- my $password = shift;
-
- if ($username ne "") {
- $password = GetPassword if !defined $password or $password eq "";
- } # if
-
- while (Login ($username, $password) != 0) {
- print "Login failed!\n";
- print "Username:";
- $username = <>;
- if ($username eq "") {
- print "Login aborted!\n";
- return undef;
- } # if
- chomp $username;
- $password = GetPassword;
- } # if
-
- return $username;
-} # Login2MAPS
-
-sub LoadListFile {
- # This function loads a ".list" file. This is to "import" our old ".list"
- # files. Note it assumes that the ".list" files have specific names.
- my $listfilename = shift;
-
- my $listtype;
-
- if ($listfilename eq "white.list") {
- $listtype = "white";
- } elsif ($listfilename eq "black.list") {
- $listtype = "black";
- } elsif ($listfilename eq "null.list") {
- $listtype = "null";
- } else {
- print "Unknown list file: $listfilename\n";
- return;
- } # if
-
- if (!open LISTFILE, "<$listfilename") {
- print "Unable to open $listfilename\n";
- return;
- } # if
-
- my $sequence = 0;
-
- Info "Adding $listfilename to $listtype list";
-
- while (<LISTFILE>) {
- chomp;
- next if m/^#/ || m/^$/;
-
- my ($pattern, $comment) = split /\,/;
-
- AddList $listtype, $pattern, 0, $comment;
- $sequence++;
- } # while
-
- if ($sequence == 0) {
- print "No messages found to load ";
- } elsif ($sequence == 1) {
- print "Loaded 1 message ";
- } else {
- print "Loaded $sequence messages ";
- } # if
- print "from $listfilename\n";
-
- close LISTFILE;
-} # LoadListFile
-
-sub LoadEmail {
- # This function loads an mbox file.
- my $file = shift;
-
- if (!open FILE, "<$file") {
- print "Unable to open \"$file\" - $!\n";
- return;
- } # if
-
- binmode FILE;
-
- my $nbr_msgs;
-
- while (! eof FILE) {
- my ($sender, $reply_to, $subject, $data) = ReadMsg (*FILE);
-
- $nbr_msgs++;
-
- AddEmail $sender, $subject, $data;
-
- Info "Added message from $sender to email";
- } # while
-
- if ($nbr_msgs == 0) {
- print "No messages found to load ";
- } elsif ($nbr_msgs == 1) {
- print "Loaded 1 message ";
- } else {
- print "Loaded $nbr_msgs messages ";
- } # if
- print "from $file\n";
-} # LoadEmail
-
-sub DumpEmail {
- # This function unloads email to a mbox file.
- my $file = shift;
-
- if (!open FILE, ">$file") {
- print "Unable to open \"$file\" - $!\n";
- return;
- } # if
-
- binmode FILE;
-
- my $i = 0;
- my $handle = FindEmail;
- my ($userid, $sender, $subject, $timestamp, $message);
-
- while (($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle) {
- print FILE $message;
- $i++;
- } # while
-
- print "$i messages dumped to $file\n";
-
- close FILE;
-} # DumpEmail
-
-sub SwitchUser {
- my $new_user = shift;
-
- if ($new_user = Login2MAPS $new_user) {
- print "You are now logged in as $new_user\n";
- } # if
-} # SwitchContext
-
-sub ShowSpace {
- my $detail = shift;
-
- my $userid = GetContext;
-
- if (defined $detail) {
- my %msg_space = MAPS::Space $userid;
-
- foreach (sort (keys (%msg_space))) {
- my $sender = $_;
- my $size = $msg_space {$_};
- format PER_MSG=
-@######### @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-$size,$sender
-.
-$~ = "PER_MSG";
- write ();
- } # foreach
- } else {
- my $total_space = MAPS::Space $userid;
- $total_space = $total_space / (1024 * 1024);
- format TOTALSIZE=
-Total size @###.### Meg
-$total_space
-.
-$~ = "TOTALSIZE";
- write ();
- } # if
-} # ShowSpace
-
-sub ShowUser {
- print "Current userid is " . GetContext () . "\n";
-} # ShowContext
-
-sub ShowUsers {
- my $handle = FindUser;
-
- my ($userid, $name, $email);
-
- format USERLIST =
-User ID: @<<<<<<<<< Name: @<<<<<<<<<<<<<<<<<<< Email: @<<<<<<<<<<<<<<<<<<<<<<<
-$userid,$name,$email
-.
-$~ = "USERLIST";
- while (($userid, $name, $email) = GetUser $handle) {
- last if ! defined $userid;
- write ();
- } # while
-
- $handle->finish;
-} # ShowUsers
-
-sub ShowEmail {
- my $handle = FindEmail;
-
- my ($userid, $sender, $subject, $timestamp, $message);
-
-format EMAIL =
-@<<<<<<<<<<<<<<<<<<<@<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-$timestamp,$sender,$subject
-.
-$~ = "EMAIL";
- while (($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle) {
- last if ! defined $userid;
- write ();
- } # while
-
- $handle->finish;
-} # ShowEmail
-
-sub ShowLog {
- my $how_many = shift;
-
- $how_many = defined $how_many ? $how_many : -20;
-
- my $handle = FindLog $how_many;
-
- my ($userid, $timestamp, $sender, $type, $message);
-
-format LOG =
-@<<<<<<<<<<<<<<<<<<<@<<<<<<<<< @<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-$timestamp,$type,$sender,$message
-.
-$~ = "LOG";
- while (($userid, $timestamp, $sender, $type, $message) = GetLog $handle) {
- last if ! defined $userid;
- write ();
- } # while
-
- $handle->finish;
-} # ShowLog
-
-sub ShowList {
- my $type = shift;
-
- my $lines = 10;
- my $next = 0;
- my @list;
- my %record;
-
-format LIST =
-@>> @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<
-$record{sequence},$record{pattern},$record{domain},$record{comment}
-.
-$~ = "LIST";
-
- while (@list = ReturnList $type, $next, $lines) {
- foreach (@list) {
- %record = %{$_};
- write ();
- } # foreach
- print "Hit any key to continue";
- ReadLine (0);
- $next += $lines;
- } # while
-} # ShowList
-
-sub ShowStats {
- my $nbr_days = shift;
-
- $nbr_days = 1 if !defined $nbr_days;
-
- my %dates = GetStats $nbr_days;
-
- foreach my $date (keys (%dates)) {
- foreach (keys (%{$dates{$date}})) {
- print "$date $_:";
- print "\t$dates{$date}{$_}\n";
- } # foreach
- } # foreach
-} # ShowStats
-
-sub Deliver {
- my $file = shift;
-
- if (!open MESSAGE, "<$file") {
- print "Unable to open message file $file\n";
- return;
- } # if
-
- my $data;
- while (<MESSAGE>) {
- $data = $data . $_;
- } # while
-
- Whitelist "Andrew\@DeFaria.com", $data;
-} # Deliver
-
-sub ParseCommand {
- # Crude parser...
- my $cmd = shift;
- my $parm1 = shift;
- my $parm2 = shift;
- my $parm3 = shift;
- my $parm4 = shift;
-
- $_ = $cmd . " ";
- SWITCH: {
- /^$/ && do {
- last SWITCH
- };
-
- /^resequence / && do {
- Resequence GetContext (), $parm1;
- last SWITCH
- };
-
- /^encrypt / && do {
- EncryptPassword $parm1, $parm2;
- last SWITCH
- };
-
- /^decrypt / && do {
- my $password = UserExists (GetContext());
- DecryptPassword $password;
- last SWITCH
- };
-
- /^deliver / && do {
- Deliver $parm1;
- last SWITCH
- };
-
- /^add2whitelist / && do {
- Add2Whitelist $parm1, GetContext (), $parm2;
- last SWITCH
- };
-
- /^showusers / && do {
- ShowUsers;
- last SWITCH
- };
-
- /^adduser / && do {
- AddUser $parm1, $parm2, $parm3, $parm4;
- last SWITCH;
- };
-
- /^cleanemail / && do {
- if ($parm1 eq "") {
- $parm1 = "9999-12-31 23:59:59";
- } # if
- my $nbr_entries = CleanEmail $parm1;
- print "$nbr_entries email entries cleaned\n";
- last SWITCH;
- };
-
- /^deleteemail / && do {
- my $nbr_entries = DeleteEmail $parm1;
- print "$nbr_entries email entries deleted\n";
- last SWITCH;
- };
-
- /^cleanlog / && do {
- if ($parm1 eq "") {
- $parm1 = "9999-12-31 23:59:59";
- } # if
- my $nbr_entries = CleanLog $parm1;
- print "$nbr_entries log entries cleaned\n";
- last SWITCH;
- };
-
- /^loadlist / && do {
- LoadListFile $parm1;
- last SWITCH;
- };
-
- /^loademail / && do {
- LoadEmail $parm1;
- last SWITCH;
- };
-
- /^dumpemail / && do {
- DumpEmail $parm1;
- last SWITCH;
- };
-
- /^log / && do {
- Logmsg "info", "$parm1 $parm2", $parm3;
- last SWITCH;
- };
-
- /^switchuser / && do {
- SwitchUser $parm1;
- last SWITCH;
- };
-
- /^showuser / && do {
- ShowUser;
- last SWITCH;
- };
-
- /^showemail / && do {
- ShowEmail;
- last SWITCH
- };
-
- /^showlog / && do {
- ShowLog $parm1;
- last SWITCH
- };
-
- /^showlist / && do {
- ShowList $parm1;
- last SWITCH
- };
-
- /^space / && do {
- ShowSpace $parm1;
- last SWITCH
- };
-
- /^showstats / && do {
- ShowStats $parm1;
- last SWITCH
- };
-
- /^help / && do {
- print "Valid commands are:\n\n";
- print "adduser <userid> <realname> <email> <password>\tAdd user to DB\n";
- print "add2whitelist <sender> <name>\t\tAdd sender to whitelist\n";
- print "cleanlog [timestamp]\t\tCleans out old log entries\n";
- print "log <message>\t\t\tLogs a message\n";
- print "loadlist <listfile>\t\t\tLoad a list file\n";
- print "cleanemail [timestamp]\t\tCleans out old email entries\n";
- print "deliver <message>\t\t\tDelivers a message\n";
- print "loademail <mbox>\t\t\tLoad an mbox file\n";
- print "dumpemail <mbox>\t\t\tDump email from DB to an mbox file\n";
- print "deleteemail <sender>\t\t\tDelete email from sender\n";
- print "switchuser <userid>\t\t\tSwitch to user\n";
- print "showuser\t\t\t\tShow current user\n";
- print "showusers\t\t\t\tShows users in the DB\n";
- print "showemail\t\t\t\tDisplays email\n";
- print "showlog <nbr>\t\t\tDisplays <nbr> log entries\n";
- print "space\t <detail>\t\t\tDisplay space usage\n";
- print "showlist <type>\t\t\tShow list by type\n";
- print "showstats <nbr>\t\t\tDisplays <nbr> days of stats\n";
- print "encrypt <password>\t\t\tEncrypt a password\n";
- print "resequence <list>\t\t\tResequences a list\n";
- print "help\t\t\t\t\tThis screen\n";
- print "exit\t\t\t\t\tExit mapsutil\n";
- last SWITCH;
- };
-
- print "Unknown command: $_";
-
- print " ($parm1" if defined $parm1;
- print ", $parm2" if defined $parm2;
- print ", $parm3" if defined $parm3;
- print ", $parm4" if defined $parm4;
-
- if (defined $parm1) {
- print ")\n";
- } else {
- print "\n";
- } # if
- } # SWITCH
-} # ParseCommand
-
-sub GetOpts {
-} # GetOpts
-
-my $maps_username = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
-my $username = Login2MAPS $maps_username, $ENV{MAPS_PASSWORD};
-
-if (defined $ARGV [0]) {
- ParseCommand $ARGV [0], $ARGV [1], $ARGV [2], $ARGV [3];
- exit;
-} # if
-
-# Use ReadLine
-my $term = new Term::ReadLine 'mapsutil';
-
-while (1) {
- $_ = $term->readline ("MAPSUtil:");
-
- last if !defined $_;
-
- my ($cmd, $parm1, $parm2, $parm3, $parm4) = split;
-
- last if ($cmd =~ /exit/i || $cmd =~ /quit/i);
-
- ParseCommand $cmd, $parm1, $parm2, $parm3, $parm4 if defined $cmd;
-} # while
-
-print "\n" if !defined $_;
-
-exit;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+# File: $RCSfile: mapsutil,v $
+# Revision: $Revision: 1.1 $
+# Description: This script implements a small command interpreter to exercise
+# MAPS functions.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+use MAPS;
+use MAPSLog;
+
+use Term::ReadLine;
+use Term::ReadLine::Gnu;
+use Term::ReadKey;
+
+my $maps_username;
+
+sub EncryptPassword($$) {
+ my ($password, $userid) = @_;
+
+ my $encrypted_password = Encrypt $password, $userid;
+
+ print "Password: $password = $encrypted_password\n";
+
+ return;
+} # EncryptPassword
+
+sub DecryptPassword($$) {
+ my ($password, $userid) = @_;
+
+ my $decrypted_password = Decrypt($password, $userid);
+
+ print "Password: $password = $decrypted_password\n";
+
+ return;
+} # DecryptPassword
+
+sub Resequence($$) {
+ my ($userid, $type) = @_;
+
+ MAPS::ResequenceList($userid, $type);
+} # Resequence
+
+sub GetPassword() {
+ print "Password:";
+ ReadMode "noecho";
+ my $password = ReadLine(0);
+ chomp $password;
+ print "\n";
+ ReadMode "normal";
+
+ return $password;
+} # GetPassword
+
+sub Login2MAPS($;$) {
+ my ($username, $password) = @_;
+
+ if ($username ne '') {
+ $password = GetPassword if !defined $password or $password eq "";
+ } # if
+
+ while (Login($username, $password) != 0) {
+ print "Login failed!\n";
+ print "Username:";
+ $username = <>;
+ if ($username eq "") {
+ print "Login aborted!\n";
+ return undef;
+ } # if
+ chomp $username;
+ $password = GetPassword;
+ } # if
+
+ return $username;
+} # Login2MAPS
+
+sub LoadListFile($) {
+ # This function loads a ".list" file. This is to "import" our old ".list"
+ # files. Note it assumes that the ".list" files have specific names.
+ my ($listfilename) = @_;
+
+ my $listtype;
+
+ if ($listfilename eq "white.list") {
+ $listtype = "white";
+ } elsif ($listfilename eq "black.list") {
+ $listtype = "black";
+ } elsif ($listfilename eq "null.list") {
+ $listtype = "null";
+ } else {
+ print "Unknown list file: $listfilename\n";
+ return;
+ } # if
+
+ my $listfile;
+
+ if (!open $listfile, '<', $listfilename) {
+ print "Unable to open $listfilename\n";
+ return;
+ } # if
+
+ my $sequence = 0;
+
+ Info("Adding $listfilename to $listtype list");
+
+ while ($listfile) {
+ chomp;
+ next if m/^#/ || m/^$/;
+
+ my ($pattern, $comment) = split /\,/;
+
+ AddList($listtype, $pattern, 0, $comment);
+ $sequence++;
+ } # while
+
+ if ($sequence == 0) {
+ print "No messages found to load ";
+ } elsif ($sequence == 1) {
+ print "Loaded 1 message ";
+ } else {
+ print "Loaded $sequence messages ";
+ } # if
+ print "from $listfilename\n";
+
+ close $listfile;
+} # LoadListFile
+
+sub LoadEmail($) {
+ # This function loads an mbox file.
+ my ($filename) = @_;
+
+ my $file;
+
+ if (!open $file, '<', $filename) {
+ print "Unable to open \"$filename\" - $!\n";
+ return;
+ } # if
+
+ binmode $file;
+
+ my $nbr_msgs;
+
+ while (!eof $file) {
+ my ($sender, $reply_to, $subject, $data) = ReadMsg (*$file);
+
+ $nbr_msgs++;
+
+ AddEmail($sender, $subject, $data);
+
+ Info("Added message from $sender to email");
+ } # while
+
+ if ($nbr_msgs == 0) {
+ print "No messages found to load ";
+ } elsif ($nbr_msgs == 1) {
+ print "Loaded 1 message ";
+ } else {
+ print "Loaded $nbr_msgs messages ";
+ } # if
+ print "from $file\n";
+} # LoadEmail
+
+sub DumpEmail($) {
+ # This function unloads email to a mbox file.
+ my ($filename) = @_;
+
+ my $file;
+
+ if (!open $file, '>', $filename) {
+ print "Unable to open \"$filename\" - $!\n";
+ return;
+ } # if
+
+ binmode $file;
+
+ my $i = 0;
+ my $handle = FindEmail;
+
+ my ($userid, $sender, $subject, $timestamp, $message);
+
+ while (($userid, $sender, $subject, $timestamp, $message) = GetEmail($handle)) {
+ print $file $message;
+ $i++;
+ } # while
+
+ print "$i messages dumped to $file\n";
+
+ close $file;
+} # DumpEmail
+
+sub SwitchUser($) {
+ my ($new_user) = @_;
+
+ if ($new_user = Login2MAPS($new_user)) {
+ print "You are now logged in as $new_user\n";
+ } # if
+} # SwitchContext
+
+sub ShowSpace($) {
+ my ($detail) = @_;
+
+ my $userid = GetContext;
+
+ if ($detail) {
+ my %msg_space = Space($userid);
+
+ for (sort (keys (%msg_space))) {
+ my $sender = $_;
+ my $size = $msg_space{$_};
+ format PER_MSG=
+@######### @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$size,$sender
+.
+$~ = "PER_MSG";
+ write ();
+ } # foreach
+ } else {
+ my $total_space = Space($userid);
+
+ $total_space = $total_space / (1024 * 1024);
+
+ format TOTALSIZE=
+Total size @###.### Meg
+$total_space
+.
+$~ = "TOTALSIZE";
+ write ();
+ } # if
+} # ShowSpace
+
+sub ShowUser() {
+ print "Current userid is " . GetContext() . "\n";
+} # ShowContext
+
+sub ShowUsers() {
+ my ($handle) = FindUser;
+
+ my ($userid, $name, $email);
+
+ format USERLIST =
+User ID: @<<<<<<<<< Name: @<<<<<<<<<<<<<<<<<<< Email: @<<<<<<<<<<<<<<<<<<<<<<<
+$userid,$name,$email
+.
+$~ = "USERLIST";
+ while (($userid, $name, $email) = GetUser($handle)) {
+ last if ! defined $userid;
+ write();
+ } # while
+
+ $handle->finish;
+} # ShowUsers
+
+sub ShowEmail() {
+ my ($handle) = FindEmail;
+
+ my ($userid, $sender, $subject, $timestamp, $message);
+
+format EMAIL =
+@<<<<<<<<<<<<<<<<<<<@<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$timestamp,$sender,$subject
+.
+$~ = "EMAIL";
+ while (($userid, $sender, $subject, $timestamp, $message) = GetEmail($handle)) {
+ last unless $userid;
+ write();
+ } # while
+
+ $handle->finish;
+} # ShowEmail
+
+sub ShowLog($) {
+ my ($how_many) = @_;
+
+ $how_many = defined $how_many ? $how_many : -20;
+
+ my $handle = FindLog($how_many);
+
+ my ($userid, $timestamp, $sender, $type, $message);
+
+format LOG =
+@<<<<<<<<<<<<<<<<<<<@<<<<<<<<< @<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$timestamp,$type,$sender,$message
+.
+$~ = "LOG";
+ while (($userid, $timestamp, $sender, $type, $message) = GetLog $handle) {
+ last unless $userid;
+ write();
+ } # while
+
+ $handle->finish;
+} # ShowLog
+
+sub ShowList($) {
+ my ($type) = @_;
+
+ my $lines = 10;
+ my $next = 0;
+ my @list;
+ my %record;
+
+format LIST =
+@>> @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<
+$record{sequence},$record{pattern},$record{domain},$record{comment}
+.
+$~ = "LIST";
+
+ while (@list = ReturnList($type, $next, $lines)) {
+ for (@list) {
+ %record = %{$_};
+ write();
+ } # for
+ print "Hit any key to continue";
+ ReadLine (0);
+ $next += $lines;
+ } # while
+} # ShowList
+
+sub ShowStats($) {
+ my ($nbr_days) = @_;
+
+ $nbr_days ||= 1;
+
+ my %dates = GetStats($nbr_days);
+
+ for my $date (keys(%dates)) {
+ for (keys(%{$dates{$date}})) {
+ print "$date $_:";
+ print "\t$dates{$date}{$_}\n";
+ } # for
+ } # for
+} # ShowStats
+
+sub Deliver($) {
+ my ($filename) = @_;
+
+ my $message;
+
+ if (!open $message, '<', $filename) {
+ print "Unable to open message file $filename\n";
+ return;
+ } # if
+
+ my $data;
+
+ while ($message) {
+ $data = $data . $_;
+ } # while
+
+ Whitelist "Andrew\@DeFaria.com", $data;
+
+ close $message;
+
+ return;
+} # Deliver
+
+sub ParseCommand($$$$$){
+ my ($cmd, $parm1, $parm2, $parm3,$parm4) = @_;
+
+ $_ = $cmd . ' ';
+
+ SWITCH: {
+ /^$/ && do {
+ last SWITCH
+ };
+
+ /^resequence / && do {
+ Resequence(GetContext(), $parm1);
+ last SWITCH
+ };
+
+ /^encrypt / && do {
+ EncryptPassword($parm1, $parm2);
+ last SWITCH
+ };
+
+ /^decrypt / && do {
+ my $password = UserExists(GetContext());
+ DecryptPassword($password, $maps_username);
+ last SWITCH
+ };
+
+ /^deliver / && do {
+ Deliver($parm1);
+ last SWITCH
+ };
+
+ /^add2whitelist / && do {
+ Add2Whitelist($parm1, GetContext(), $parm2);
+ last SWITCH
+ };
+
+ /^showusers / && do {
+ ShowUsers;
+ last SWITCH
+ };
+
+ /^adduser / && do {
+ AddUser($parm1, $parm2, $parm3, $parm4);
+ last SWITCH;
+ };
+
+ /^cleanemail / && do {
+ if ($parm1 eq '') {
+ $parm1 = "9999-12-31 23:59:59";
+ } # if
+ my $nbr_entries = CleanEmail($parm1);
+ print "$nbr_entries email entries cleaned\n";
+ last SWITCH;
+ };
+
+ /^deleteemail / && do {
+ my $nbr_entries = DeleteEmail($parm1);
+ print "$nbr_entries email entries deleted\n";
+ last SWITCH;
+ };
+
+ /^cleanlog / && do {
+ if ($parm1 eq '') {
+ $parm1 = "9999-12-31 23:59:59";
+ } # if
+ my $nbr_entries = CleanLog($parm1);
+ print "$nbr_entries log entries cleaned\n";
+ last SWITCH;
+ };
+
+ /^loadlist / && do {
+ LoadListFile($parm1);
+ last SWITCH;
+ };
+
+ /^loademail / && do {
+ LoadEmail($parm1);
+ last SWITCH;
+ };
+
+ /^dumpemail / && do {
+ DumpEmail($parm1);
+ last SWITCH;
+ };
+
+ /^log / && do {
+ Logmsg("info", "$parm1 $parm2", $parm3);
+ last SWITCH;
+ };
+
+ /^switchuser / && do {
+ SwitchUser($parm1);
+ last SWITCH;
+ };
+
+ /^showuser / && do {
+ ShowUser;
+ last SWITCH;
+ };
+
+ /^showemail / && do {
+ ShowEmail;
+ last SWITCH
+ };
+
+ /^showlog / && do {
+ ShowLog($parm1);
+ last SWITCH
+ };
+
+ /^showlist / && do {
+ ShowList($parm1);
+ last SWITCH
+ };
+
+ /^space / && do {
+ ShowSpace($parm1);
+ last SWITCH
+ };
+
+ /^showstats / && do {
+ ShowStats($parm1);
+ last SWITCH
+ };
+
+ /^help / && do {
+ print "Valid commands are:\n\n";
+ print "adduser <userid> <realname> <email> <password>\tAdd user to DB\n";
+ print "add2whitelist <sender> <name>\t\tAdd sender to whitelist\n";
+ print "cleanlog [timestamp]\t\tCleans out old log entries\n";
+ print "log <message>\t\t\tLogs a message\n";
+ print "loadlist <listfile>\t\t\tLoad a list file\n";
+ print "cleanemail [timestamp]\t\tCleans out old email entries\n";
+ print "deliver <message>\t\t\tDelivers a message\n";
+ print "loademail <mbox>\t\t\tLoad an mbox file\n";
+ print "dumpemail <mbox>\t\t\tDump email from DB to an mbox file\n";
+ print "deleteemail <sender>\t\t\tDelete email from sender\n";
+ print "switchuser <userid>\t\t\tSwitch to user\n";
+ print "showuser\t\t\t\tShow current user\n";
+ print "showusers\t\t\t\tShows users in the DB\n";
+ print "showemail\t\t\t\tDisplays email\n";
+ print "showlog <nbr>\t\t\tDisplays <nbr> log entries\n";
+ print "space\t <detail>\t\t\tDisplay space usage\n";
+ print "showlist <type>\t\t\tShow list by type\n";
+ print "showstats <nbr>\t\t\tDisplays <nbr> days of stats\n";
+ print "encrypt <password>\t\t\tEncrypt a password\n";
+ print "resequence <list>\t\t\tResequences a list\n";
+ print "help\t\t\t\t\tThis screen\n";
+ print "exit\t\t\t\t\tExit mapsutil\n";
+ last SWITCH;
+ };
+
+ print "Unknown command: $_";
+
+ print " ($parm1" if $parm1;
+ print ", $parm2" if $parm2;
+ print ", $parm3" if $parm3;
+ print ", $parm4" if $parm4;
+ print ")\n";
+ } # SWITCH
+} # ParseCommand
+
+$maps_username = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
+
+my $username = Login2MAPS($maps_username, $ENV{MAPS_PASSWORD});
+
+if ($ARGV[0]) {
+ ParseCommand($ARGV[0], $ARGV[1], $ARGV[2], $ARGV[3], $ARGV[4]);
+ exit;
+} # if
+
+# Use ReadLine
+my $term = new Term::ReadLine 'mapsutil';
+
+while (1) {
+ $_ = $term->readline ("MAPSUtil:");
+
+ last unless $_;
+
+ my ($cmd, $parm1, $parm2, $parm3, $parm4) = split;
+
+ last if ($cmd =~ /exit/i || $cmd =~ /quit/i);
+
+ ParseCommand($cmd, $parm1, $parm2, $parm3, $parm4) if defined $cmd;
+} # while
+
+print "\n" unless $_;
+
+exit;
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
use CGI qw/:standard/;
use CGI::Carp 'fatalsToBrowser';
-my $userid = cookie ('MAPSUser');
-my $type = param ('type');
-my $next = param ('next');
+my $userid = cookie('MAPSUser');
+my $type = param('type');
+my $next = param('next');
$userid ||= $ENV{USER};
my @names = param;
my @sequence_nbrs;
- foreach (@names) {
+ for (@names) {
if (/pattern(\d+)/) {
push @sequence_nbrs, $1;
} # if
- } # foreach
+ } # for
return @sequence_nbrs;
} # ReturnSequenceNbrs
my $i = 0;
foreach (ReturnSequenceNbrs) {
- UpdateList
+ UpdateList(
$userid,
$type,
- param ("pattern$_"),
- param ("domain$_"),
- param ("comment$_"),
- param ("hit_count$_"),
- $_;
+ param("pattern$_"),
+ param("domain$_"),
+ param("comment$_"),
+ param("hit_count$_"),
+ $_,
+ );
$i++;
-} # foreach
+} # for
if ($i eq 0) {
print redirect ("/maps/php/list.php?type=$type&next=$next&message=Unable to update entries");
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
my @names = param;
my @sequence_nbrs;
- foreach (@names) {
+ for (@names) {
if (/action(\d+)/) {
push @sequence_nbrs, $1;
} # if
- } # foreach
+ } # for
return @sequence_nbrs;
} # ReturnSequenceNbrs
my $count;
foreach (@sequence_nbrs) {
- $count += DeleteList $type, $_;
+ $count += DeleteList($type, $_);
} # foreach
if ($count == 0) {
- DisplayError 'Nothing to delete!';
+ DisplayError('Nothing to delete!');
} else {
- ResequenceList $userid, $type;
+ ResequenceList($userid, $type);
if ($count == 1) {
print redirect ("/maps/php/list.php?type=$type&next=$next&message=Deleted entry");
($pattern, $domain) = split /\@/, $email;
} # if
- $hit_count = CountMsg $email;
+ $hit_count = CountMsg($email);
} # if
print Tr [
# empty, editable entries (possibly filled in) for the user to add
# the new entry
my $selected = @selected;
- my $nextseq = MAPSDB::GetNextSequenceNo $userid, $type;
+ my $nextseq = GetNextSequenceNo($userid, $type);
my $next = ($nextseq - $lines) + $selected - 1;
$next = 0
my $Type = ucfirst $type;
- Heading (
+ Heading(
'getcookie',
'',
"Add to $Type List",
@scripts
);
- NavigationBar $userid;
+ NavigationBar($userid);
# Now display table and new entry
print start_form {
th {-class => 'tablerightend'}, 'Hit Count'
];
- my @list = ReturnList $type, $next, $lines;
+ my @list = ReturnList($type, $next, $lines);
my %record;
my $i = 1;
- foreach (@list) {
+ for (@list) {
$i++;
%record = %{$_};
td {-class => 'tablerightdata',
-align => 'right'}, $hit_count,
];
- } # foreach
+ } # for
# Now the input line(s)
if (@selected == 0) {
- PrintInputLine $nextseq, undef, 'tablebottomleft', 'tablebottomdata',
- 'tablebottomright';
+ PrintInputLine($nextseq, undef, 'tablebottomleft', 'tablebottomdata',
+ 'tablebottomright');
} else {
- foreach (@selected) {
+ for (@selected) {
my $leftclass = $i == $lines ? 'tablebottomleft' : 'tableleftdata';
my $dataclass = $i == $lines ? 'tablebottomdata' : 'tabledata';
my $rightclass = $i == $lines ? 'tablebottomright' : 'tablerightdata';
$i++;
- PrintInputLine $nextseq++, $_, $leftclass, $dataclass, $rightclass;
- } # foreach
+ PrintInputLine($nextseq++, $_, $leftclass, $dataclass, $rightclass);
+ } # for
} # for
print end_table;
my $Type = ucfirst $type;
- Heading (
+ Heading(
'getcookie',
'',
"Modify $Type List",
@scripts
);
- NavigationBar $userid;
+ NavigationBar($userid);
# Redisplay the page but open up the lines that are getting modified
print start_form {
th {-class => 'tablerightend'}, 'Hit Count',
];
- my @list = ReturnList $type, $next, $lines;
+ # Corner case: If on the first page (i.e. $next=0) then being zero based, we
+ # will actually get 21 entries in @list (i.e. $next=0, $lines=20 - 21 $entries
+ # are retrieved). So in that case, and that case only, we will change $lines
+ # to $lines - 1.
+ --$lines if $next == 0;
+
+ my @list = ReturnList($type, $next, $lines);
my %record;
my $s = 0;
my $i = 1;
- foreach (@list) {
+ for (@list) {
%record = %{$_};
my $sequence = $record{sequence};
- my $leftclass = ($i eq $lines || $sequence eq $total) ?
+ my $leftclass = ($i == @list || $sequence eq $total) ?
'tablebottomleft' : 'tableleftdata';
- my $dataclass = ($i eq $lines || $sequence eq $total) ?
+ my $dataclass = ($i == @list || $sequence eq $total) ?
'tablebottomdata' : 'tabledata';
- my $rightclass = ($i eq $lines || $sequence eq $total) ?
+ my $rightclass = ($i == @list || $sequence eq $total) ?
'tablebottomright' : 'tablerightdata';
$i++;
my $hit_count = $record{hit_count} ? $record{hit_count} : '';
print
- td {-class => $dataclass,
- -align => 'right'},
+ td {-class => $dataclass,
+ -align => 'right'},
(textfield {-class => 'inputfield',
-style => 'width:100%',
-align => 'right',
-maxlength => '255',
-name => "pattern$sequence",
-value => $pattern}),
- td {-class => $dataclass,
- -align => 'center'}, '@',
- td {-class => $dataclass},
+ td {-class => $dataclass,
+ -align => 'center'}, '@',
+ td {-class => $dataclass},
(textfield {-class => 'inputfield',
-style => 'width:100%',
-align => 'left',
-maxlength => '255',
-name => "domain$sequence",
-value => $domain}),
- td {-class => $dataclass},
- (textfield {-class => 'inputfield',
- -style => 'width:100%',
- -align => 'left',
- -size => 25,
- -maxlength => '255',
- -name => "comment$sequence",
- -value => $comment}),
- td {-class => $rightclass},
+ td {-class => $dataclass},
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '255',
+ -name => "comment$sequence",
+ -value => $comment}),
+ td {-class => $rightclass},
(textfield {-class => 'inputfield',
-style => 'width:100%',
-align => 'left',
} # if
print end_Tr;
- } # foreach
+ } # for
print end_table;
print br,
} # ModifyEntries
sub WhitelistMarked {
- AddNewEntry 'white', ReturnSequenceNbrs;
+ AddNewEntry('white', ReturnSequenceNbrs);
} # WhitelistMarked
sub BlacklistMarked {
- AddNewEntry 'black', ReturnSequenceNbrs;
+ AddNewEntry('black', ReturnSequenceNbrs);
} # BlacklistMarked
sub NulllistMarked {
- AddNewEntry 'null', ReturnSequenceNbrs;
+ AddNewEntry('null', ReturnSequenceNbrs);
} # NulllistMarked
# Main
$userid ||= $ENV{USER};
-SetContext $userid;
+SetContext($userid);
-my %options = GetUserOptions $userid;
+my %options = GetUserOptions($userid);
$lines = $options{'Page'};
-$total = MAPSDB::count 'list', "userid = \"$userid\" and type = \"$type\""
- if $type;
+$total = count('list', "userid = \"$userid\" and type = \"$type\"") if $type;
if ($action eq 'Add New Entry') {
- AddNewEntry $type;
+ AddNewEntry($type);
} elsif ($action eq 'Delete Marked') {
- DeleteEntries $type;
+ DeleteEntries($type);
} elsif ($action eq 'Modify Marked') {
- ModifyEntries $type;
+ ModifyEntries($type);
} elsif ($action eq 'Whitelist Marked') {
WhitelistMarked;
} elsif ($action eq 'Blacklist Marked') {
} elsif ($action eq 'Nulllist Marked') {
NulllistMarked;
} else {
- Heading (
+ Heading(
'getcookie',
'',
"Unknown action ($action)",
"Unknown action ($action)"
);
- NavigationBar $userid;
- DisplayError "Unknown action encountered ($action)";
+ NavigationBar($userid);
+ DisplayError("Unknown action encountered ($action)");
} # if
-Footing $table_name;
+Footing($table_name);
exit;
################################################################################
#
# File: $RCSfile: register.cgi,v $
-# Revision: $Revision: 1.1 $
+# Revision: $Revision: 1.1 $
# Description: Register a MAPS user
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
use CGI qw/:standard/;
-my $fullname = param ("fullname");
-my $sender = lc (param ("sender"));
-my $userid = param ("userid");
+my $fullname = param("fullname");
+my $sender = lc(param("sender"));
+my $userid = param("userid");
-sub MyFooting {
- print div ({-align => "center"},
- button (-name => "close",
- -value => "Close Window",
- -onClick => "window.close ()"));
+sub MyFooting() {
+ print div({-align => "center"},
+ button (-name => "close",
+ -value => "Close Window",
+ -onClick => "window.close ()")
+ );
print end_html;
} # MyFooting
-sub MyError {
- my $errmsg = shift;
+sub MyError($) {
+ my ($errmsg) = @_;
print h3 ({-class => "error",
-align => "center"}, "ERROR: " . $errmsg);
exit 1;
} # MyError
-sub MyHeading {
+sub MyHeading() {
print
- header (-title => "MAPS Registration"),
- start_html (-title => "MAPS Registration",
- -author => "Andrew\@DeFaria.com",
- -style => {-src => "/maps/css/MAPSPlain.css"});
+ header(-title => "MAPS Registration"),
+ start_html(-title => "MAPS Registration",
+ -author => "Andrew\@DeFaria.com",
+ -style => {-src => "/maps/css/MAPSPlain.css"}
+ );
print
- h2 ({-class => "header",
- -align => "center"},
+ h2 ({-class => "header",
+ -align => "center"},
font ({-class => "standout"},
- "MAPS"), "Registration Results");
+ "MAPS"), "Registration Results"
+ );
} # MyHeading
# Main
MyHeading;
-if ($sender eq "") {
- MyError "Sender not specified!";
-}
+MyError("Sender not specified!") if $sender eq '';
-my $rule;
+my ($status, $rule) = OnWhitelist($sender, $userid, 0);
-if (OnWhitelist $sender, $userid) {
- MyError "The email address $sender is already on ${userid}'s list"
+if ($status) {
+ MyError("The email address $sender is already on ${userid}'s list)");
} # if
-my $messages = Add2Whitelist $sender, $userid, $fullname;
+my $messages = Add2Whitelist($sender, $userid, $fullname);
print p "$fullname, your email address, $sender, has been added to ${userid}'s white list.";
################################################################################
#
# File: $RCSfile: registerform.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Register a MAPS user
+# Revision: $Revision: 1.1 $
+# Description: Register a MAPS user
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
# Modified: $Date: 2013/06/12 14:05:47 $
use CGI qw/:standard *table start_div end_div/;
+use lib "$FindBin::Bin/../lib";
+
use MAPS;
use MAPSWeb;
-my $userid = param ("userid");
-my $Userid = ucfirst $userid;
-my $sender = param ("sender");
-my $errormsg = param ("errormsg");
+my $userid = param ('userid');
+my $Userid = ucfirst $userid;
+my $sender = param ('sender');
+my $errormsg = param ('errormsg');
-sub Heading {
+sub MyHeading {
print
- header (-title => "MAPS Registration"),
+ header (-title => "MAPS Registration"),
start_html (-title => "MAPS Registration",
- -author => "Andrew\@DeFaria.com",
- -style => {-src => "/maps/css/MAPSPlain.css"},
- -script => [{ -language => "JavaScript1.2",
- -src => "/maps/JavaScript/MAPSUtils.js"},
- { -language => "JavaScript1.2",
- -src => "/maps/JavaScript/CheckRegistration.js"}
- ]);
+ -author => "Andrew\@DeFaria.com",
+ -style => {-src => "/maps/css/MAPSPlain.css"},
+ -script => [{ -language => "JavaScript1.2",
+ -src => "/maps/JavaScript/MAPSUtils.js"},
+ { -language => "JavaScript1.2",
+ -src => "/maps/JavaScript/CheckRegistration.js"}
+ ]);
print
h2 ({-class => "header", -align => "center"},
font ({-class => "standout"}, "MAPS"),
"Mail Authorization and Permission System");
- if (defined $errormsg) {
+ if ($errormsg) {
DisplayError $errormsg;
exit;
} # if
-} # Heading
+} # MyHeading
sub Body {
print start_div {-class => "content"};
print p ("${Userid}'s email is protected by MAPS, a spam elimination
- system. In order to email $Userid you must register. You need
- only register once to be added to ${Userid}'s <i>white list</i>,
- thereafter you should have no problems emailing them. This is not
- unlike the acceptance procedure for many instant messaging clients.");
+ system. In order to email $Userid you must register. You need
+ only register once to be added to ${Userid}'s <i>white list</i>,
+ thereafter you should have no problems emailing them. This is not
+ unlike the acceptance procedure for many instant messaging clients.");
print p ("Please enter your full name and click on Register to complete the
- registration.");
+ registration.");
print start_form {
- -method => "post",
- -action => "register.cgi",
- -onSubmit => "return validate (this);"
+ -method => "post",
+ -action => "register.cgi",
+ -onSubmit => "return validate (this);"
};
print start_table {
- -cellpadding => 2,
- -cellspacing => 0,
- -border => 0,
- -align => "center",
- -width => "360"
+ -cellpadding => 2,
+ -cellspacing => 0,
+ -border => 0,
+ -align => "center",
+ -width => "360"
};
- print hidden (-name => "userid",
- -value => "$userid");
+ print hidden (-name => "userid",
+ -value => "$userid");
print Tr [
td ({-class => "header"}, "Full name:") .
- td (textfield {-class => "inputfield",
- -size => 50,
- -name => "fullname"})
+ td (textfield {-class => "inputfield",
+ -size => 50,
+ -name => "fullname"})
];
- print hidden (-name => "sender",
- -value => "$userid");
+ print hidden (-name => "sender",
+ -value => "$userid");
print end_table;
- print p {-align => "center"},
- submit (-name => "submit",
- -value => "Register");
+ print p {-align => "center"},
+ submit (-name => "submit",
+ -value => "Register");
print end_form;
print p ("Tired of dealing with unsolicited email (AKA SPAM)? Want to know
- more about MAPS, the Mail Authorization and Permission System for
- eliminating SPAM? Click",
- a ({-href => "/maps/",
- -target => "_blank"},
- "here"),
- "to find out more.");
+ more about MAPS, the Mail Authorization and Permission System for
+ eliminating SPAM? Click",
+ a ({-href => "/maps/",
+ -target => "_blank"},
+ "here"),
+ "to find out more.");
print start_table {
- -cellpadding => 2,
- -cellspacing => 0,
- -border => 1,
- -align => "center",
- -width => "50%"
+ -cellpadding => 2,
+ -cellspacing => 0,
+ -border => 1,
+ -align => "center",
+ -width => "50%"
};
print Tr [
td ({-class => "note",
- -align => "center"}, "Note")
+ -align => "center"}, "Note")
];
print Tr [
td ({-class => "notetext"},
print end_div;
} # Body
-if (!defined $userid) {
+if (!$userid) {
$errormsg = "Internal error: Userid not specified";
} else {
if (!UserExists ($userid)) {
} # if
}
-Heading;
+MyHeading;
Body;
Footing;
################################################################################
#
# File: $RCSfile: search.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Search by sender and subject
+# Revision: $Revision: 1.1 $
+# Description: Search by sender and subject
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
# Modified: $Date: 2013/06/12 14:05:47 $
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
use CGI qw (:standard *table start_Tr start_td start_div end_Tr end_td end_div);
use CGI::Carp "fatalsToBrowser";
-my $str = param ("str");
-my $next = param ("next");
-my $lines = param ("lines");
+my $str = param('str');
+my $next = param('next');
+my $lines = param('lines');
my $userid;
my $prev;
my $total;
my $last;
-my $table_name = "searchresults";
+my $table_name = 'searchresults';
sub MakeButtons {
my $prev_button = $prev >= 0 ?
my $buttons = $prev_button;
$buttons = $buttons .
- submit ({-name => "action",
- -value => "Whitelist Marked",
- -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
- submit ({-name => "action",
- -value => "Blacklist Marked",
- -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
- submit ({-name => "action",
- -value => "Nulllist Marked",
- -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
- submit ({-name => "action",
- -value => "Reset Marks",
- -onClick => "return ClearAll (document.detail);"});
+ submit ({-name => "action",
+ -value => "Whitelist Marked",
+ -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
+ submit ({-name => "action",
+ -value => "Blacklist Marked",
+ -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
+ submit ({-name => "action",
+ -value => "Nulllist Marked",
+ -onClick => "return CheckAtLeast1Checked (document.detail);"}) .
+ submit ({-name => "action",
+ -value => "Reset Marks",
+ -onClick => "return ClearAll (document.detail);"});
return $buttons . $next_button;
} # MakeButtons
print div {-align => "center"}, b (
"(" . $current . "-" . $last . " of " . $total . ")");
print start_form {
- -method => "post",
- -action => "processaction.cgi",
- -name => "detail"
+ -method => "post",
+ -action => "processaction.cgi",
+ -name => "detail"
};
my $buttons = MakeButtons;
- print div {-align => "center",
- -class => "toolbar"}, $buttons;
- print start_table ({-align => "center",
- -id => $table_name,
- -border => 0,
- -cellspacing => 0,
- -cellpadding => 0,
- -width => "100%"}) . "\n";
+ print div {-align => "center",
+ -class => "toolbar"}, $buttons;
+ print start_table ({-align => "center",
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 0,
+ -width => "100%"}) . "\n";
print
Tr [
th {-class => "tableleftend"},
- th {-class => "tableheader"}, "Sender",
- th {-class => "tableheader"}, "Subject",
- th {-class => "tablerightend"}, "Date"
+ th {-class => "tableheader"}, "Sender",
+ th {-class => "tableheader"}, "Subject",
+ th {-class => "tablerightend"}, "Date"
];
foreach (@emails) {
print Tr [
td {-class => "tableleftdata",
- -align => "center"},
- (checkbox {-name => "action$next",
- -label => ""}),
- hidden ({-name => "email$next",
- -default => $sender}),
- td {-class => "sender"},
- a {-href => "mailto:$sender"}, $display_sender,
- td {-class => "subject"},
- a {-href => "display.cgi?sender=$sender"}, $subject,
- td {-class => "dateright",
- -width => "115"}, SQLDatetime2UnixDatetime $date
+ -align => "center"},
+ (checkbox {-name => "action$next",
+ -label => ""}),
+ hidden ({-name => "email$next",
+ -default => $sender}),
+ td {-class => "sender"},
+ a {-href => "mailto:$sender"}, $display_sender,
+ td {-class => "subject"},
+ a {-href => "display.cgi?sender=$sender"}, $subject,
+ td {-class => "dateright",
+ -width => "115"}, SQLDatetime2UnixDatetime $date
];
} # foreach
print end_table;
DisplayError "No search string specified" if !defined $str;
-if (!defined $lines) {
+if (!$lines) {
my %options = GetUserOptions $userid;
$lines = $options{"Page"};
} # if
-$total = MAPSDB::count "email",
+$total = count "email",
"userid = \"$userid\" and (subject like \"%$str%\" or sender like \"%$str%\")";
DisplayError "Nothing matching!" if $total eq 0;
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::New;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
use CGI qw (:standard);
-my $userid = param ("userid");
-my $fullname = param ("fullname");
-my $email = param ("email");
-my $password = param ("password");
-my $repeated_password = param ("repeated_password");
-my $mapspop = param ("MAPSPOP");
-my $history = param ("history");
-my $days = param ("days");
-my $dates = param ("dates");
-my $tag_and_forward = param ("tag_and_forward");
+my $userid = param('userid');
+my $fullname = param('fullname');
+my $email = param('email');
+my $password = param('password');
+my $repeated_password = param('repeated_password');
+my $mapspop = param('MAPSPOP');
+my $history = param('history');
+my $days = param('days');
+my $dates = param('dates');
+my $tag_and_forward = param('tag_and_forward');
my $message;
sub MyError {
my $errmsg = shift;
$userid = Heading (
- "getcookie",
- "",
- "Signup",
- "Signup"
+ 'getcookie',
+ '',
+ 'Signup',
+ 'Signup'
);
NavigationBar $userid;
- print h2 {-align => "center",
- -class => "error"}, "Error: " . $errmsg;
+ print h2 {-align => 'center',
+ -class => 'error'}, 'Error: ' . $errmsg;
Footing;
sub Body {
# Check required fields
- if ($userid eq "" ) {
- MyError "You must specify a userid!";
+ if ($userid eq '' ) {
+ MyError 'You must specify a userid!';
} # if
- if ($email eq "" ) {
- MyError "You must specify an email address!";
+ if ($email eq '' ) {
+ MyError 'You must specify an email address!';
} # if
- if ($password eq "") {
- MyError "You must specify a password!";
+ if ($password eq '') {
+ MyError 'You must specify a password!';
} # if
- if ($fullname eq "") {
- MyError "You must specify your full name!";
+ if ($fullname eq '') {
+ MyError 'You must specify your full name!';
} # if
# Password field checks
if (length $password < 6) {
- MyError "Password must be longer than 6 characters!";
+ MyError 'Password must be longer than 6 characters!';
} # if
if ($password ne $repeated_password) {
- MyError "Passwords do not match";
+ MyError 'Passwords do not match';
} # if
- my $status = AddUser $userid, $fullname, $email, $password;
+ my $status = AddUser($userid, $fullname, $email, $password);
if ($status ne 0) {
- MyError "Username already exists";
+ MyError 'Username already exists';
} # if
my %options = (
- "MAPSPOP" => $mapspop,
- "History" => $history,
- "Page" => $days,
- "Dates" => $dates,
- "Tag&Forward" => $tag_and_forward
+ MAPSPOP => $mapspop,
+ History => $history,
+ Page => $days,
+ Dates => $dates,
+ 'Tag&Forward' => $tag_and_forward,
);
- my $status = AddUserOptions $userid, %options;
+ my $status = AddUserOptions($userid, %options);
if ($status == 0) {
print redirect ("/maps/?errormsg=User account \"$userid\" created.<br>You may now login");
################################################################################
#
# File: $RCSfile: stats.cgi,v $
-# Revision: $Revision: 1.1 $
+# Revision: $Revision: 1.1 $
# Description: This script produces a table of statistics of mail processed for
-# the user.
+# the user.
# Author: Andrew@DeFaria.com
# Created: Fri Nov 29 14:17:21 2002
# Modified: $Date: 2013/06/12 14:05:47 $
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
use MAPSWeb;
use CGI qw (:standard *table start_Tr end_Tr);
-use CGI::Carp "fatalsToBrowser";
+use CGI::Carp 'fatalsToBrowser';
-my $nbr_days = param ("nbr_days");
-my $date = param ("date");
+my $nbr_days = param('nbr_days');
+my $date = param('date');
-my $table_name = "stats";
+my $table_name = 'stats';
$date = defined $date ? $date : Today2SQLDatetime;
sub Body {
- print start_table ({-align => "center",
- -id => $table_name,
- -border => 0,
- -cellspacing => 0,
- -cellpadding => 2,
- -cols => 9,
- -width => "100%"});
- print start_Tr {-valign => "bottom"};
- print th {-class => "tableleftend"}, "Date";
-
- foreach (@Types) {
- print th {-class => "tableheader"}, ucfirst;
- } # foreach
-
- print th {-class => "tablerightend"}, "Total";
-
- my %dates = GetStats $nbr_days, $date;
+ print start_table ({-align => 'center',
+ -id => $table_name,
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2,
+ -cols => 9,
+ -width => '100%'});
+ print start_Tr {-valign => 'bottom'};
+ print th {-class => 'tableleftend'}, 'Date';
+
+ for (@Types) {
+ print th {-class => 'tableheader'}, ucfirst;
+ } # for
+
+ print th {-class => 'tablerightend'}, 'Total';
+
+ my %dates = GetStats($nbr_days, $date);
my %totals;
- foreach my $date (sort {$b cmp $a} (keys (%dates))) {
+ for my $date (sort {$b cmp $a} (keys (%dates))) {
print start_Tr;
- print td {-class => "tablerightleftdata",
- -align => "center"}, FormatDate $date;
+ print td {-class => 'tablerightleftdata',
+ -align => 'center'}, FormatDate $date;
my $day_total = 0;
- foreach (@Types) {
+ for (@Types) {
my $value = $dates{$date}{$_};
- if ($value eq 0) {
- print td {-class => "tabledata"}, " ";
+ if ($value == 0) {
+ print td {-class => 'tabledata'}, ' ';
} else {
- print td {-class => "tabledata",
- -align => "center"},
- a {-href => "detail.cgi?type=$_;date=$date"},
- $value;
+ print td {-class => 'tabledata',
+ -align => 'center'},
+ a {-href => "detail.cgi?type=$_;date=$date"},
+ $value;
} # if
$totals{$_} += $value;
$day_total += $value;
- } # foreach
+ } # for
- if ($day_total eq 0) {
- print td {-class => "tableleftrightdata"}, " ";
+ if ($day_total == 0) {
+ print td {-class => 'tableleftrightdata'}, ' ';
} else {
- print td {-class => "tableleftrightdata",
- -align => "center"}, $day_total;
+ print td {-class => 'tableleftrightdata',
+ -align => 'center'}, $day_total;
} # if
print end_Tr;
- } # foreach
+ } # for
my $grand_total = 0;
print start_Tr;
- print th {-class => "tablebottomlefttotal"}, "Totals";
+ print th {-class => 'tablebottomlefttotal'}, 'Totals';
- foreach (@Types) {
+ for (@Types) {
if ($totals{$_} eq 0) {
- print td {-class => "tablebottomtotal"}, " ";
+ print td {-class => 'tablebottomtotal'}, ' ';
} else {
- print td {-class => "tablebottomtotal",
- -align => "center"},
- a {-href => "detail.cgi?type=$_"}, $totals{$_};
+ print td {-class => 'tablebottomtotal',
+ -align => 'center'},
+ a {-href => "detail.cgi?type=$_"}, $totals{$_};
} # if
$grand_total += $totals{$_};
- } # foreach
+ } # for
- print td {-class => "tablebottomrighttotal",
- -align => "center"}, $grand_total;
+ print td {-class => 'tablebottomrighttotal',
+ -align => 'center'}, $grand_total;
print end_Tr;
print end_table;
# Main
my $userid = Heading (
- "getcookie",
- "",
- "Statistics",
- "Statistics",
- "",
+ 'getcookie',
+ '',
+ 'Statistics',
+ 'Statistics',
+ '',
$table_name
);
-SetContext $userid;
+SetContext($userid);
-if (!defined $nbr_days) {
+if (!$nbr_days) {
my %options = GetUserOptions $userid;
- $nbr_days = $options{"Dates"};
+ $nbr_days = $options{Dates};
} # if
-NavigationBar $userid;
+NavigationBar($userid);
Body;
-Footing $table_name;
+Footing($table_name);
exit;
################################################################################
#
# File: $RCSfile: updateprofile.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Update the users profile
+# Revision: $Revision: 1.1 $
+# Description: Update the users profile
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
# Modified: $Date: 2013/06/12 14:05:47 $
use FindBin;
$0 = $FindBin::Script;
-use lib $FindBin::Bin;
+use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
my $userid;
my $Userid;
-my $fullname = param ("fullname");
-my $email = param ("email");
-my $old_password = param ("old_password");
-my $new_password = param ("new_password");
-my $repeated_password = param ("repeated_password");
-my $mapspop = param ("MAPSPOP");
-my $history = param ("history");
-my $days = param ("days");
-my $dates = param ("dates");
-my $tag_and_forward = param ("tag_and_forward");
+my $fullname = param('fullname');
+my $email = param('email');
+my $old_password = param('old_password');
+my $new_password = param('new_password');
+my $repeated_password = param('repeated_password');
+my $mapspop = param('MAPSPOP');
+my $history = param('history');
+my $days = param('days');
+my $dates = param('dates');
+my $tag_and_forward = param('tag_and_forward');
sub Body {
my %options = (
- "MAPSPOP" => $mapspop,
- "History" => $history,
- "Page" => $days,
- "Dates" => $dates,
- "Tag&Forward" => $tag_and_forward
+ MAPSPOP => $mapspop,
+ History => $history,
+ Page => $days,
+ Dates => $dates,
+ 'Tag&Forward' => $tag_and_forward,
);
- if (defined $old_password && $old_password ne "") {
- my $dbpassword = UserExists $userid;
- my $encrypted_old_password = Encrypt $old_password, $userid;
+ if ($old_password && $old_password ne '') {
+ my $dbpassword = UserExists($userid);
+ my $encrypted_old_password = Encrypt($old_password, $userid);
if ($dbpassword ne $encrypted_old_password) {
- DisplayError "Your old password was not correct!";
+ DisplayError 'Your old password was not correct!';
} # if
} # if
- if (UpdateUser ($userid, $fullname, $email, $new_password) != 0) {
+ if (UpdateUser($userid, $fullname, $email, $new_password) != 0) {
DisplayError "Unable to update user record for user $userid";
} # if
- if (UpdateUserOptions ($userid, %options) != 0) {
+ if (UpdateUserOptions($userid, %options) != 0) {
DisplayError "Unable to update user options for user $userid";
} # if
- print h2 {-class => "header",
- -align => "center"},
+ print h2 {-class => 'header',
+ -align => 'center'},
"${Userid}'s profile has been updated";
} # Body
$userid = Heading (
- "getcookie",
- "",
- "Update Profile",
- "Update user's profile"
+ 'getcookie',
+ '',
+ 'Update Profile',
+ "Update user's profile",
);
$Userid = ucfirst $userid;
-SetContext $userid;
-NavigationBar $userid;
-Body;
-Footing;
+
+SetContext($userid);
+NavigationBar($userid);
+Body();
+Footing();
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+#
+# File: $RCSfile: MAPS.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: Main module for Mail Authentication and Permission System (MAPS)
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2018, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPS;
+
+use strict;
+use warnings;
+
+use DBI;
+use Carp;
+use FindBin;
+use vars qw(@ISA @EXPORT);
+use Exporter;
+
+use MAPSLog;
+use MAPSFile;
+use MAPSUtil;
+use MIME::Entity;
+
+# Globals
+my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
+my %useropts;
+my $DB;
+
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ Add2Blacklist
+ Add2Nulllist
+ Add2Whitelist
+ AddEmail
+ AddList
+ AddLog
+ AddUser
+ AddUserOptions
+ Blacklist
+ CleanEmail
+ CleanLog
+ CleanList
+ CountMsg
+ Decrypt
+ DeleteEmail
+ DeleteList
+ DeleteLog
+ Encrypt
+ FindEmail
+ FindList
+ FindLog
+ FindUser
+ ForwardMsg
+ GetContext
+ GetEmail
+ GetList
+ GetLog
+ GetNextSequenceNo
+ GetRows
+ GetUser
+ GetUserOptions
+ ListLog
+ ListUsers
+ Login
+ Nulllist
+ OnBlacklist
+ OnNulllist
+ OnWhitelist
+ OptimizeDB
+ ReadMsg
+ ResequenceList
+ ReturnList
+ ReturnListEntry
+ ReturnMsg
+ ReturnMessages
+ ReturnSenders
+ SaveMsg
+ SearchEmails
+ SetContext
+ Space
+ UpdateList
+ UpdateUser
+ UpdateUserOptions
+ UserExists
+ Whitelist
+ count
+ countlog
+ count_distinct
+);
+
+my $mapsbase = "$FindBin::Bin/..";
+
+sub Add2Blacklist($$$) {
+ # Add2Blacklist will add an entry to the blacklist
+ my ($sender, $userid, $comment) = @_;
+
+ # First SetContext to the userid whose black list we are adding to
+ SetContext($userid);
+
+ # Add to black list
+ AddList("black", $sender, 0, $comment);
+
+ # Log that we black listed the sender
+ Info("Added $sender to " . ucfirst $userid . "'s black list");
+
+ # Delete old emails
+ my $count = DeleteEmail($sender);
+
+ # Log out many emails we managed to remove
+ Info("Removed $count emails from $sender");
+
+ return;
+} # Add2Blacklist
+
+sub Add2Nulllist($$;$$) {
+ # Add2Nulllist will add an entry to the nulllist
+ my ($sender, $userid, $comment, $hit_count) = @_;
+
+ # First SetContext to the userid whose null list we are adding to
+ SetContext($userid);
+
+ # Add to null list
+ AddList("null", $sender, 0, $comment, $hit_count);
+
+ # Log that we null listed the sender
+ Info("Added $sender to " . ucfirst $userid . "'s null list");
+
+ # Delete old emails
+ my $count = DeleteEmail($sender);
+
+ # Log out many emails we managed to remove
+ Info("Removed $count emails from $sender");
+
+ return;
+} # Add2Nulllist
+
+sub Add2Whitelist($$;$) {
+ # Add2Whitelist will add an entry to the whitelist
+ my ($sender, $userid, $comment) = @_;
+
+ # First SetContext to the userid whose white list we are adding to
+ SetContext($userid);
+
+ # Add to white list
+ AddList('white', $sender, 0, $comment);
+
+ # Log that we registered a user
+ Logmsg("registered", $sender, "Registered new sender");
+
+ # Check to see if there are any old messages to deliver
+ my $handle = FindEmail($sender);
+
+ my ($dbsender, $subject, $timestamp, $message);
+
+ # Deliver old emails
+ my $messages = 0;
+ my $return_status = 0;
+
+ while (($userid, $dbsender, $subject, $timestamp, $message) = GetEmail($handle)) {
+ last unless $userid;
+
+ $return_status = Whitelist($sender, $message);
+
+ last if $return_status;
+
+ $messages++;
+ } # while
+
+ # Done with $handle
+ $handle->finish;
+
+ # Return if we has a problem delivering email
+ return $return_status if $return_status;
+
+ # Remove delivered messages.
+ DeleteEmail($sender);
+
+ return $messages;
+} # Add2Whitelist
+
+sub AddEmail($$$) {
+ my ($sender, $subject, $data) = @_;
+
+ # "Sanitize" some fields so that characters that are illegal to SQL are escaped
+ $sender = 'Unknown' if (!defined $sender || $sender eq '');
+ $sender = $DB->quote($sender);
+ $subject = $DB->quote($subject);
+ $data = $DB->quote($data);
+
+ my $timestamp = UnixDatetime2SQLDatetime(scalar(localtime));
+ my $statement = "insert into email values (\"$userid\", $sender, $subject, \"$timestamp\", $data)";
+
+ $DB->do ($statement)
+ or DBError('AddEmail: Unable to do statement', $statement);
+
+ return;
+} # AddEmail
+
+sub AddList($$$;$$$) {
+ my ($listtype, $pattern, $sequence, $comment, $hit_count, $last_hit) = @_;
+
+ $hit_count //= CountMsg($pattern);
+
+ my ($user, $domain) = split /\@/, $pattern;
+
+ if (!$domain || $domain eq '') {
+ $domain = 'NULL';
+ $pattern = $DB->quote($user);
+ } else {
+ $domain = "'$domain'";
+
+ if ($user eq '') {
+ $pattern = 'NULL';
+ } else {
+ $pattern = $DB->quote($user);
+ } # if
+ } # if
+
+ if (!$comment || $comment eq '') {
+ $comment = 'NULL';
+ } else {
+ $comment = $DB->quote($comment);
+ } # if
+
+ # Get next sequence #
+ if ($sequence == 0) {
+ $sequence = GetNextSequenceNo($userid, $listtype);
+ } # if
+
+ $last_hit //= UnixDatetime2SQLDatetime(scalar (localtime));
+
+ my $statement = "insert into list values (\"$userid\", \"$listtype\", $pattern, $domain, $comment, $sequence, $hit_count, \"$last_hit\")";
+
+ $DB->do($statement)
+ or DBError('AddList: Unable to do statement', $statement);
+
+ return;
+} # AddList
+
+sub AddLog ($$$) {
+ my ($type, $sender, $msg) = @_;
+
+ my $timestamp = UnixDatetime2SQLDatetime(scalar(localtime));
+ my $statement;
+
+ # Use quote to protect ourselves
+ $msg = $DB->quote($msg);
+
+ if ($sender eq '') {
+ $statement = "insert into log values (\"$userid\", \"$timestamp\", null, \"$type\", $msg)";
+ } else {
+ $statement = "insert into log values (\"$userid\", \"$timestamp\", \"$sender\", \"$type\", $msg)";
+ } # if
+
+ $DB->do($statement)
+ or DBError('AddLog: Unable to do statement', $statement);
+
+ return;
+} # AddLog
+
+sub AddUser($$$$) {
+ my ($userid, $realname, $email, $password) = @_;
+
+ $password = Encrypt($password, $userid);
+
+ if (UserExists($userid)) {
+ return 1;
+ } else {
+ my $statement = "insert into user values ('$userid', '$realname', '$email', '$password')";
+
+ $DB->do($statement)
+ or DBError('AddUser: Unable to do statement', $statement);
+ } # if
+
+ return 0;
+} # Adduser
+
+sub AddUserOptions($%) {
+ my ($userid, %options) = @_;
+
+ for (keys %options) {
+ return 1 if !UserExists($userid);
+
+ my $statement = "insert into useropts values ('$userid', '$_', '$options{$_}')";
+
+ $DB->do($statement)
+ or DBError('AddUserOption: Unable to do statement', $statement);
+ } # for
+
+ return 0;
+} # AddUserOptions
+
+sub Blacklist($%) {
+ # Blacklist will send a message back to the $sender telling them that
+ # they've been blacklisted. Currently we save a copy of the message.
+ # In the future we should just disregard the message.
+ my ($sender, $sequence, $hit_count, @msg) = @_;
+
+ # Check to see if this sender has already emailed us.
+ my $msg_count = CountMsg($sender);
+
+ if ($msg_count < 5) {
+ # Bounce email
+ SendMsg($sender, "Your email has been discarded by MAPS", "$mapsbase/blacklist.html", @msg);
+ Logmsg("blacklist", $sender, "Sent blacklist reply");
+ } else {
+ Logmsg("mailloop", $sender, "Mail loop encountered");
+ } # if
+
+ RecordHit("black", $sequence, ++$hit_count) if $sequence;
+
+ return;
+} # Blacklist
+
+sub CheckOnList ($$;$) {
+ # CheckOnList will check to see if the $sender is on the $listfile.
+ # Return 1 if found 0 if not.
+ my ($listtype, $sender, $update) = @_;
+
+ $update //= 1;
+
+ my $status = 0;
+ my ($rule, $sequence, $hit_count);
+
+ my $statement = 'select pattern, domain, comment, sequence, hit_count '
+ . "from list where userid = '$userid' and type = '$listtype' "
+ . 'order by sequence';
+
+ my $sth = $DB->prepare($statement)
+ or DBError('CheckOnList: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('CheckOnList: Unable to execute statement', $statement);
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ $hit_count = pop (@row);
+ $sequence = pop (@row);
+ my $comment = pop (@row);
+ my $domain = pop (@row);
+ my $pattern = pop (@row);
+ my $email_on_file;
+
+ unless ($domain) {
+ $email_on_file = $pattern;
+ } else {
+ unless ($pattern) {
+ $email_on_file = '@' . $domain;
+ } else {
+ $email_on_file = $pattern . '@' . $domain;
+ } # if
+ } # unless
+
+ # Escape some special characters
+ $email_on_file =~ s/\@/\\@/;
+ $email_on_file =~ s/^\*/.\*/;
+
+ # We want to terminate the search string with a "$" iff there's an
+ # "@" in there. This is because some "email_on_file" may have no
+ # domain (e.g. "mailer-daemon" with no domain). In that case we
+ # don't want to terminate the search string with a "$" rather we
+ # wish to terminate it with an "@". But in the case of say
+ # "@ti.com" if we don't terminate the search string with "$" then
+ # "@ti.com" would also match "@tixcom.com"!
+ my $search_for = $email_on_file =~ /\@/
+ ? "$email_on_file\$"
+ : !defined $domain
+ ? "$email_on_file\@"
+ : $email_on_file;
+ if ($sender =~ /$search_for/i) {
+ $rule = "Matching rule: ($listtype:$sequence) \"$email_on_file\"";
+ $rule .= " - $comment" if $comment and $comment ne '';
+ $status = 1;
+
+ RecordHit($listtype, $sequence, ++$hit_count) if $update;
+
+ last;
+ } # if
+ } # while
+
+ $sth->finish;
+
+ return ($status, $rule, $sequence, $hit_count);
+} # CheckOnList
+
+sub CleanEmail($) {
+ my ($timestamp) = @_;
+
+ # First see if anything needs to be deleted
+ my $count = 0;
+
+ my $statement = "select count(*) from email where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ my $sth = $DB->prepare($statement)
+ or DBError('CleanEmail: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('CleanEmail: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries were deleted
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ $count = 0
+ } else {
+ $count = $row[0];
+ } # unless
+
+ # Just return if there's nothing to delete
+ return $count if ($count == 0);
+
+ # Delete emails for userid whose older than $timestamp
+ $statement = "delete from email where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ $sth = $DB->prepare($statement)
+ or DBError('CleanEmail: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('CleanEmail: Unable to execute statement', $statement);
+
+ return $count;
+} # ClearEmail
+
+sub CleanLog($) {
+ my ($timestamp) = @_;
+
+ # First see if anything needs to be deleted
+ my $count = 0;
+
+ my $statement = "select count(*) from log where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ my $sth = $DB->prepare($statement)
+ or DBError($DB, 'CleanLog: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('CleanLog: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries were deleted
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ $count = 0
+ } else {
+ $count = $row[0];
+ } # unless
+
+ # Just return if there's nothing to delete
+ return $count if ($count == 0);
+
+ # Delete log entries for userid whose older than $timestamp
+ $statement = "delete from log where userid = '$userid' and timestamp < '$timestamp'";
+
+ # Prepare statement
+ $sth = $DB->prepare($statement)
+ or DBError('CleanLog: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('CleanLog: Unable to execute statement', $statement);
+
+ return $count;
+} # CleanLog
+
+sub CleanList($;$) {
+ my ($timestamp, $listtype) = @_;
+
+ $listtype //= 'null';
+
+ # First see if anything needs to be deleted
+ my $count = 0;
+
+ my $statement = "select count(*) from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
+
+ # Prepare statement
+ my $sth = $DB->prepare($statement)
+ or DBError($DB, 'CleanList: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('CleanList: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries were deleted
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ $count = $row[0] ? $row[0] : 0;
+
+ # Just return if there's nothing to delete
+ return $count if ($count == 0);
+
+ # Get data for these entries
+ $statement = "select type, sequence, hit_count from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
+
+ # Prepare statement
+ $sth = $DB->prepare($statement)
+ or DBError('CleanList: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('CleanList: Unable to execute statement', $statement);
+
+ $count = 0;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ my $hit_count = pop(@row);
+ my $sequence = pop(@row);
+ my $listtype = pop(@row);
+
+ if ($hit_count == 0) {
+ $count++;
+
+ $statement = "delete from list where userid='$userid' and type='$listtype' and sequence=$sequence";
+ $DB->do($statement)
+ or DBError('CleanList: Unable to execute statement', $statement);
+ } else {
+ # Age entry: Sometimes entries are initially very popular and
+ # the $hit_count gets very high quickly. Then the domain is
+ # abandoned and no activity happens. One case recently observed
+ # was for phentermine.com. The $hit_count initially soared to
+ # 1920 within a few weeks. Then it all stopped as of
+ # 07/13/2007. Obvisously this domain was shutdown. With the
+ # previous aging algorithm of simply subtracting 1 this
+ # phentermine.com entry would hang around for over 5 years!
+ #
+ # So the tack here is to age the entry by 10% until the $hit_count
+ # is less than 30 then we revert to the old method of subtracting 1.
+ if ($hit_count < 30) {
+ $hit_count--;
+ } else {
+ $hit_count = int($hit_count / 1.1);
+ } # if
+
+ $statement = "update list set hit_count=$hit_count where userid='$userid' and type='$listtype' and sequence=$sequence;";
+ $DB->do($statement)
+ or DBError('CleanList: Unable to execute statement', $statement);
+ } # if
+ } # while
+
+ ResequenceList($userid, $listtype);
+
+ return $count;
+} # CleanList
+
+sub CloseDB() {
+ $DB->disconnect;
+
+ return;
+} # CloseDB
+
+sub CountMsg($) {
+ my ($sender) = @_;
+
+ return count('email', "userid = '$userid' and sender like '%$sender%'");
+} # CountMsg
+
+sub DBError($$) {
+ my ($msg, $statement) = @_;
+
+ print 'MAPS::' . $msg . "\nError #" . $DB->err . ' ' . $DB->errstr . "\n";
+
+ if ($statement) {
+ print "SQL Statement: $statement\n";
+ } # if
+
+ exit $DB->err;
+} # DBError
+
+sub Decrypt ($$) {
+ my ($password, $userid) = @_;
+
+ my $statement = "select decode('$password','$userid')";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('Decrypt: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('Decrypt: Unable to execute statement', $statement);
+
+ # Get return value, which should be the encoded password
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ return $row[0]
+} # Decrypt
+
+sub DeleteEmail($) {
+ my $sender = shift;
+
+ my ($username, $domain) = split /@/, $sender;
+ my $condition;
+
+ if ($username eq '') {
+ $condition = "userid = '$userid' and sender like '%\@$domain'";
+ } else {
+ $condition = "userid = '$userid' and sender = '$sender'";
+ } # if
+
+ # First see if anything needs to be deleted
+ my $count = count('email', $condition);
+
+ # Just return if there's nothing to delete
+ return $count if ($count == 0);
+
+ my $statement = 'delete from email where ' . $condition;
+
+ $DB->do($statement)
+ or DBError('DeleteEmail: Unable to execute statement', $statement);
+
+ return $count;
+} # DeleteEmail
+
+sub DeleteList($$) {
+ my ($type, $sequence) = @_;
+
+ # First see if anything needs to be deleted
+ my $count = count('list', "userid = '$userid' and type = '$type' and sequence = '$sequence'");
+
+ # Just return if there's nothing to delete
+ return $count if ($count == 0);
+
+ my $statement = "delete from list where userid = '$userid' and type = '$type' and sequence = '$sequence'";
+
+ $DB->do($statement)
+ or DBError('DeleteList: Unable to execute statement', $statement);
+
+ return $count;
+} # DeleteList
+
+sub DeleteLog($) {
+ my ($sender) = @_;
+
+ my ($username, $domain) = split /@/, $sender;
+ my $condition;
+
+ if ($username eq '') {
+ $condition = "userid = '$userid' and sender like '%\@$domain'";
+ } else {
+ $condition = "userid = '$userid' and sender = '$sender'";
+ } # if
+
+ # First see if anything needs to be deleted
+ my $count = count('log', $condition);
+
+ # Just return if there's nothing to delete
+ return $count if ($count == 0);
+
+ my $statement = 'delete from log where ' . $condition;
+
+ $DB->do($statement)
+ or DBError('DeleteLog: Unable to execute statement', $statement);
+
+ return $count;
+} # DeleteLog
+
+sub Encrypt($$) {
+ my ($password, $userid) = @_;
+
+ my $statement = "select encode('$password','$userid')";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('Encrypt: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('Encrypt: Unable to execute statement', $statement);
+
+ # Get return value, which should be the encoded password
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ return $row[0];
+} # Encrypt
+
+sub FindEmail(;$) {
+ my ($sender) = @_;
+
+ my $statement;
+
+ if (!defined $sender || $sender eq '') {
+ $statement = "select * from email where userid = '$userid'";
+ } else {
+ $statement = "select * from email where userid = '$userid' and sender = '$sender'";
+ } # if
+
+ my $sth = $DB->prepare($statement)
+ or DBError('FindEmail: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('FindEmail: Unable to execute statement', $statement);
+
+ return $sth;
+} # FindEmail
+
+sub FindList($;$) {
+ my ($type, $sender) = @_;
+
+ my $statement;
+
+ unless ($sender) {
+ $statement = "select * from list where userid = '$userid' and type = '$type'";
+ } else {
+ my ($pattern, $domain) = split /\@/, $sender;
+ $statement = "select * from list where userid = '$userid' and type = '$type' " .
+ "and pattern = '$pattern' and domain = '$domain'";
+ } # unless
+
+ # Prepare statement
+ my $sth = $DB->prepare($statement)
+ or DBError('FindList: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('FindList: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries were deleted
+ return $sth;
+} # FindList
+
+sub FindLog($) {
+ my ($how_many) = @_;
+
+ my $start_at = 0;
+ my $end_at = countlog();
+
+ if ($how_many < 0) {
+ $start_at = $end_at - abs ($how_many);
+ $start_at = 0 if ($start_at < 0);
+ } # if
+
+ my $statement = "select * from log where userid = '$userid' order by timestamp limit $start_at, $end_at";
+
+ # Prepare statement
+ my $sth = $DB->prepare($statement)
+ or DBError('FindLog: Unable to prepare statement', $statement);
+
+ # Execute statement
+ $sth->execute
+ or DBError('FindLog: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries were deleted
+ return $sth;
+} # FindLog
+
+sub FindUser(;$) {
+ my ($userid) = @_;
+
+ my $statement;
+
+ if (!defined $userid || $userid eq '') {
+ $statement = 'select * from user';
+ } else {
+ $statement = "select * from user where userid = '$userid'";
+ } # if
+
+ my $sth = $DB->prepare($statement)
+ or DBError('FindUser: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('FindUser: Unable to execute statement', $statement);
+
+ return $sth;
+} # FindUser
+
+sub GetContext() {
+ return $userid;
+} # GetContext
+
+sub GetEmail($) {
+ my ($sth) = @_;
+
+ my @email;
+
+ if (@email = $sth->fetchrow_array) {
+ my $message = pop @email;
+ my $timestamp = pop @email;
+ my $subject = pop @email;
+ my $sender = pop @email;
+ my $userid = pop @email;
+ return $userid, $sender, $subject, $timestamp, $message;
+ } else {
+ return;
+ } # if
+} # GetEmail
+
+sub GetList($) {
+ my ($sth) = @_;
+
+ my @list;
+
+ if (@list = $sth->fetchrow_array) {
+ my $last_hit = pop @list;
+ my $hit_count = pop @list;
+ my $sequence = pop @list;
+ my $comment = pop @list;
+ my $domain = pop @list;
+ my $pattern = pop @list;
+ my $type = pop @list;
+ my $userid = pop @list;
+ return $userid, $type, $pattern, $domain, $comment, $sequence, $hit_count, $last_hit;
+ } else {
+ return;
+ } # if
+} # GetList
+
+sub GetLog($) {
+ my ($sth) = @_;
+
+ my @log;
+
+ if (@log = $sth->fetchrow_array) {
+ my $message = pop @log;
+ my $type = pop @log;
+ my $sender = pop @log;
+ my $timestamp = pop @log;
+ my $userid = pop @log;
+ return $userid, $timestamp, $sender, $type, $message;
+ } else {
+ return;
+ } # if
+} # GetLog
+
+sub GetNextSequenceNo($$) {
+ my ($userid, $listtype) = @_;
+
+ my $count = count ('list', "userid = '$userid' and type = '$listtype'");
+
+ return $count + 1;
+} # GetNextSequenceNo
+
+sub GetUser($) {
+ my ($sth) = @_;
+
+ my @user;
+
+ if (@user = $sth->fetchrow_array) {
+ my $password = pop @user;
+ my $email = pop @user;
+ my $name = pop @user;
+ my $userid = pop @user;
+ return ($userid, $name, $email, $password);
+ } else {
+ return;
+ } # if
+} # GetUser
+
+sub GetUserInfo($) {
+ my ($userid) = @_;
+
+ my $statement = "select name, email from user where userid='$userid'";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('GetUserInfo: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('GetUserInfo: Unable to execute statement', $statement);
+
+ my @userinfo = $sth->fetchrow_array;
+ my $user_email = lc (pop @userinfo);
+ my $username = lc (pop @userinfo);
+
+ $sth->finish;
+
+ return ($username, $user_email);
+} # GetUserInfo
+
+sub GetUserOptions($) {
+ my ($userid) = @_;
+
+ my $statement = "select * from useropts where userid = '$userid'";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('GetUserOptions: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('GetUserOptions: Unable to execute statement', $statement);
+
+ my @useropts;
+
+ # Empty hash
+ %useropts = ();
+
+ while (@useropts = $sth->fetchrow_array) {
+ my $value = pop @useropts;
+ my $name = pop @useropts;
+
+ pop @useropts;
+
+ $useropts{$name} = $value;
+ } # while
+
+ $sth->finish;
+
+ return %useropts;
+} # GetUserOptions
+
+sub GetRows ($) {
+ my ($statement) = @_;
+
+ my $sth = $DB->prepare($statement)
+ or DBError('Unable to prepare statement' , $statement);
+
+ $sth->execute
+ or DBError('Unable to execute statement' , $statement);
+
+ my @array;
+
+ while (my @row = $sth->fetchrow_array) {
+ for (@row) {
+ push @array, $_;
+ } # for
+ } # while
+
+ return @array;
+} # GetRows
+
+sub Login($$) {
+ my ($userid, $password) = @_;
+
+ $password = Encrypt($password, $userid);
+
+ # Check if user exists
+ my $dbpassword = UserExists($userid);
+
+ # Return -1 if user doesn't exist
+ return -1 if !$dbpassword;
+
+ # Return -2 if password does not match
+ if ($password eq $dbpassword) {
+ SetContext($userid);
+ return 0
+ } else {
+ return -2
+ } # if
+} # Login
+
+sub Nulllist($;$$) {
+ # Nulllist will simply discard the message.
+ my ($sender, $sequence, $hit_count) = @_;
+
+ RecordHit("null", $sequence, ++$hit_count) if $sequence;
+
+ # Discard Message
+ Logmsg("nulllist", $sender, "Discarded message");
+
+ return;
+} # Nulllist
+
+sub OnBlacklist($;$) {
+ my ($sender, $update) = @_;
+
+ return CheckOnList('black', $sender, $update);
+} # OnBlacklist
+
+sub OnNulllist($;$) {
+ my ($sender, $update) = @_;
+
+ return CheckOnList("null", $sender, $update);
+} # CheckOnNulllist
+
+sub OnWhitelist($;$$) {
+ my ($sender, $userid, $update) = @_;
+
+ SetContext($userid) if $userid;
+
+ return CheckOnList("white", $sender, $update);
+} # OnWhitelist
+
+sub OpenDB($$) {
+ my ($username, $password) = @_;
+
+ my $dbname = 'MAPS';
+ my $dbdriver = 'mysql';
+ my $dbserver = $ENV{MAPS_SERVER} || 'localhost';
+
+ if (!$DB || $DB eq '') {
+ #$dbserver='localhost';
+ $DB = DBI->connect("DBI:$dbdriver:$dbname:$dbserver", $username, $password, {PrintError => 0})
+ or croak "Couldn't connect to $dbname database as $username\n" . $DBI::errstr;
+ } # if
+
+ return $DB;
+} # OpenDB
+
+BEGIN {
+ my $MAPS_username = "maps";
+ my $MAPS_password = "spam";
+
+ OpenDB($MAPS_username, $MAPS_password);
+} # BEGIN
+
+END {
+ CloseDB;
+} # END
+
+
+sub OptimizeDB() {
+ my $statement = 'lock tables email read, list read, log read, user read, useropts read';
+ my $sth = $DB->prepare($statement)
+ or DBError('OptimizeDB: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('OptimizeDB: Unable to execute statement', $statement);
+
+ $statement = 'check table email, list, log, user, useropts';
+ $sth = $DB->prepare($statement)
+ or DBError('OptimizeDB: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('OptimizeDB: Unable to execute statement', $statement);
+
+ $statement = 'unlock tables';
+ $sth = $DB->prepare($statement)
+ or DBError('OptimizeDB: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('OptimizeDB: Unable to execute statement', $statement);
+
+ $statement = 'optimize table email, list, log, user, useropts';
+ $sth = $DB->prepare($statement)
+ or DBError('OptimizeDB: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('OptimizeDB: Unable to execute statement', $statement);
+
+ return;
+} # OptimizeDB
+
+sub ReadMsg($) {
+ # Reads an email message file from $input. Returns sender, subject,
+ # date and data, which is a copy of the entire message.
+ my ($input) = @_;
+
+ my $sender = '';
+ my $sender_long = '';
+ my $envelope_sender = '';
+ my $reply_to = '';
+ my $subject = '';
+ my $data = '';
+ my @data;
+
+ # Find first message's "From " line indicating start of message
+ while (<$input>) {
+ chomp;
+ last if /^From /;
+ } # while
+
+ # If we hit eof here then the message was garbled. Return indication of this
+ if (eof($input)) {
+ $data = "Garbled message - unable to find From line";
+ return $sender, $sender_long, $reply_to, $subject, $data;
+ } # if
+
+ if (/From (\S*)/) {
+ $envelope_sender = $1;
+ $sender_long = $envelope_sender;
+ } # if
+
+ push @data, $_ if /^From /;
+
+ while (<$input>) {
+ chomp;
+ push @data, $_;
+
+ # Blank line indicates start of message body
+ last if ($_ eq "" || $_ eq "\r");
+
+ # Extract sender's address
+ if (/^from: .*/i) {
+ $_ = substr ($_, 6);
+
+ $sender_long = $_;
+
+ if (/<(\S*)@(\S*)>/) {
+ $sender = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)\ /) {
+ $sender = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)/) {
+ $sender = lc ("$1\@$2");
+ } # if
+ } elsif (/^subject: .*/i) {
+ $subject = substr ($_, 9);
+ } elsif (/^reply-to: .*/i) {
+ $_ = substr ($_, 10);
+ if (/<(\S*)@(\S*)>/) {
+ $reply_to = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)\ /) {
+ $reply_to = lc ("$1\@$2");
+ } elsif (/(\S*)@(\S*)/) {
+ $reply_to = lc ("$1\@$2");
+ } # if
+ } # if
+ } # while
+
+ # Read message body
+ while (<$input>) {
+ chomp;
+
+ last if (/^From /);
+ push @data, $_;
+ } # while
+
+ # Set file pointer back by length of the line just read
+ seek ($input, -length () - 1, 1) if !eof $input;
+
+ # Sanitize email addresses
+ $envelope_sender =~ s/\<//g;
+ $envelope_sender =~ s/\>//g;
+ $envelope_sender =~ s/\"//g;
+ $envelope_sender =~ s/\'//g;
+ $sender =~ s/\<//g;
+ $sender =~ s/\>//g;
+ $sender =~ s/\"//g;
+ $sender =~ s/\'//g;
+ $reply_to =~ s/\<//g;
+ $reply_to =~ s/\>//g;
+ $reply_to =~ s/\"//g;
+ $reply_to =~ s/\'//g;
+
+ # Determine best addresses
+ $sender = $envelope_sender if $sender eq "";
+ $reply_to = $sender if $reply_to eq "";
+
+ return $sender, $sender_long, $reply_to, $subject, join "\n", @data;
+} # ReadMsg
+
+sub RecordHit($$$) {
+ my ($listtype, $sequence, $hit_count) = @_;
+
+ my $current_date = UnixDatetime2SQLDatetime(scalar(localtime));
+
+ my $statement = "update list set hit_count=$hit_count, last_hit='$current_date' where userid='$userid' and type='$listtype' and sequence=$sequence";
+
+ $DB->do($statement)
+ or DBError('RecordHit: Unable to do statement', $statement);
+
+ return;
+} # RecordHit
+
+sub ResequenceList($$) {
+ my ($userid, $type) = @_;
+
+ return 1 if $type ne 'white' && $type ne 'black' && $type ne 'null';
+
+ return 2 unless UserExists($userid);
+
+ my $statement = 'lock tables list write';
+ my $sth = $DB->prepare($statement)
+ or DBError('ResquenceList: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ResequenceList: Unable to execute statement', $statement);
+
+ # Now get all of the list entries renumbering as we go
+ $statement = <<"END";
+select
+ pattern,
+ domain,
+ comment,
+ sequence,
+ hit_count,
+ last_hit
+from
+ list
+where
+ userid = '$userid' and
+ type = '$type'
+order by
+ hit_count desc
+END
+
+ $sth = $DB->prepare($statement)
+ or DBError('ResequenceList: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ResequenceList: Unable to execute statement', $statement);
+
+ my $sequence = 1;
+ my @new_rows;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ my %record = (
+ last_hit => pop @row,
+ hit_count => pop @row,
+ new_sequence => $sequence++,
+ old_sequence => pop @row,
+ comment => $DB->quote(pop @row) || '',
+ domain => $DB->quote(pop @row) || '',
+ pattern => $DB->quote(pop @row) || '',
+ );
+
+ push @new_rows, \%record;
+ } # while
+
+ # Delete all of the list entries for this $userid and $type
+ $statement = "delete from list where userid='$userid' and type='$type'";
+
+ $DB->do($statement)
+ or DBError('ResequenceList: Unable to do statement', $statement);
+
+ # Re-add list with new sequence numbers
+ for (@new_rows) {
+ my %record = %$_;
+ my $statement = <<"END";
+insert into
+ list
+values (
+ '$userid',
+ '$type',
+ $record{pattern},
+ $record{domain},
+ $record{comment},
+ '$record{new_sequence}',
+ '$record{hit_count}',
+ '$record{last_hit}'
+)
+END
+
+ $DB->do($statement)
+ or DBError('ResequenceList: Unable to do statement', $statement);
+ } # for
+
+ $statement = 'unlock tables';
+ $sth = $DB->prepare($statement)
+ or DBError('OptimizeDB: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('OptimizeDB: Unable to execute statement', $statement);
+
+ return 0;
+} # ResequenceList
+
+sub ResequenceListold($$) {
+ my ($userid, $type) = @_;
+
+ return 1 if $type ne 'white' && $type ne 'black' && $type ne 'null';
+
+ return 2 unless UserExists($userid);
+
+ my $statement = "select sequence from list where userid = '$userid' "
+ . " and type = '$type' order by sequence";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('ResequenceList: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ResequenceList: Unable to execute statement', $statement);
+
+ my $sequence = 1;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ my $old_sequence = pop @row;
+
+ if ($old_sequence != $sequence) {
+ my $update_statement = "update list set sequence = $sequence " .
+ "where userid = '$userid' and " .
+ "type = '$type' and sequence = $old_sequence";
+
+ $DB->do($update_statement)
+ or DBError('ResequenceList: Unable to do statement', $statement);
+ } # if
+
+ $sequence++;
+ } # while
+
+ return 0;
+} # ResequenceList
+
+sub ReturnEmails($$$;$$) {
+ my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
+
+ $start_at ||= 0;
+
+ my $statement;
+
+ if ($date) {
+ my $sod = $date . ' 00:00:00';
+ my $eod = $date . ' 23:59:59';
+
+ if ($type eq 'returned') {
+ $statement = <<"END";
+select
+ log.sender
+from
+ log,
+ email
+where
+ log.sender = email.sender and
+ log.userid = '$userid' and
+ log.timestamp > '$sod' and
+ log.timestamp < '$eod' and
+ log.type = '$type'
+group by
+ log.sender
+limit
+ $start_at, $nbr_emails
+END
+ } else {
+ $statement = <<"END";
+select
+ sender
+from
+ log
+where
+ userid = '$userid' and
+ timestamp > '$sod' and
+ timestamp < '$eod' and
+ type = '$type'
+group by
+ sender
+limit
+ $start_at, $nbr_emails
+END
+ } # if
+ } else {
+ if ($type eq 'returned') {
+ $statement = <<"END";
+select
+ log.sender
+from
+ log,
+ email
+where
+ log.sender = email.sender and
+ log.userid = '$userid' and
+ log.type = '$type'
+group by
+ log.sender
+order by
+ log.timestamp desc
+limit
+ $start_at, $nbr_emails
+END
+ } else {
+ $statement = <<"END";
+select
+ sender
+from
+ log
+where
+ userid = '$userid' and
+ type = '$type'
+group by
+ sender
+order by
+ timestamp desc
+limit
+ $start_at, $nbr_emails
+END
+ } # if
+ } # if
+
+ my $sth = $DB->prepare($statement)
+ or DBError('ReturnEmails: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ReturnEmails: Unable to execute statement', $statement);
+
+ my @emails;
+
+ while (my $sender = $sth->fetchrow_array) {
+ my $earliestDate;
+
+ # Get emails for this sender. Format an array of subjects and timestamps.
+ my @messages;
+
+ $statement = "select timestamp, subject from email where userid = '$userid' " .
+ "and sender = '$sender'";
+
+ my $sth2 = $DB->prepare($statement)
+ or DBError('ReturnEmails: Unable to prepare statement', $statement);
+
+ $sth2->execute
+ or DBError('ReturnEmails: Unable to execute statement', $statement);
+
+ while (my @row = $sth2->fetchrow_array) {
+ my $subject = pop @row;
+ my $date = pop @row;
+
+ if ($earliestDate) {
+ my $earliestDateShort = substr $earliestDate, 0, 10;
+ my $dateShort = substr $date, 0, 10;
+
+ if ($earliestDateShort eq $dateShort and
+ $earliestDate > $date) {
+ $earliestDate = $date if $earliestDateShort eq $dateShort;
+ } # if
+ } else {
+ $earliestDate = $date;
+ } # if
+
+ push @messages, [$subject, $date];
+ } # while
+
+ # Done with sth2
+ $sth2->finish;
+
+ $earliestDate ||= '';
+
+ unless ($type eq 'returned') {
+ push @emails, [$earliestDate, [$sender, @messages]];
+ } else {
+ push @emails, [$earliestDate, [$sender, @messages]]
+ if @messages > 0;
+ } # unless
+ } # while
+
+ # Done with $sth
+ $sth->finish;
+
+ return @emails;
+} # ReturnEmails
+
+sub ReturnList($$$) {
+ my ($type, $start_at, $lines) = @_;
+
+ $lines ||= 10;
+
+ my $statement;
+
+ if ($start_at) {
+ $statement = "select * from list where userid = '$userid' " .
+ "and type = '$type' order by sequence " .
+ "limit $start_at, $lines";
+ } else {
+ $statement = "select * from list where userid = '$userid' " .
+ "and type = '$type' order by sequence";
+ } # if
+
+ my $sth = $DB->prepare($statement)
+ or DBError('ReturnList: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ReturnList: Unable to execute statement', $statement);
+
+ my @list;
+ my $i = 0;
+
+ while (my @row = $sth->fetchrow_array) {
+ last if $i++ > $lines;
+
+ my %list;
+
+ $list{last_hit} = pop @row;
+ $list{hit_count} = pop @row;
+ $list{sequence} = pop @row;
+ $list{comment} = pop @row;
+ $list{domain} = pop @row;
+ $list{pattern} = pop @row;
+ $list{type} = pop @row;
+ $list{userid} = pop @row;
+ push @list, \%list;
+ } # for
+
+ return @list;
+} # ReturnList
+
+sub ReturnListEntry($$) {
+ my ($type, $sequence) = @_;
+
+ my $statement = "select * from list where userid = '$userid' " .
+ "and type = '$type' and sequence = '$sequence'";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('ReturnListEntry: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ReturnListEntry: Unable to execute statement', $statement);
+
+ my %list;
+ my @row = $sth->fetchrow_array;
+
+ $list{sequence} = pop @row;
+ $list{comment} = pop @row;
+ $list{domain} = pop @row;
+ $list{pattern} = pop @row;
+ $list{type} = pop @row;
+ $list{userid} = pop @row;
+
+ return %list;
+} # ReturnListEntry
+
+# Added reply_to. Previously we passed reply_to into here as sender. This
+# caused a problem in that we were filtering as per sender but logging it
+# as reply_to. We only need reply_to for SendMsg so as to honor reply_to
+# so we now pass in both sender and reply_to
+sub ReturnMsg($$$$) {
+ # ReturnMsg will send back to the $sender the register message.
+ # Messages are saved to be delivered when the $sender registers.
+ my ($sender, $reply_to, $subject, $data) = @_;
+
+ # Check to see if this sender has already emailed us.
+ my $msg_count = CountMsg($sender);
+
+ if ($msg_count < 5) {
+ # Return register message
+ my @msg;
+
+ for (split /\n/,$data) {
+ push @msg, "$_\n";
+ } # for
+
+ SendMsg($reply_to,
+ "Your email has been returned by MAPS",
+ "$mapsbase/register.html",
+ GetContext,
+ @msg)
+ if $msg_count == 0;
+ Logmsg("returned", $sender, "Sent register reply");
+ # Save message
+ SaveMsg($sender, $subject, $data);
+ } else {
+ Add2Nulllist($sender, GetContext, "Auto Null List - Mail loop");
+ Logmsg("mailloop", $sender, "Mail loop encountered");
+ } # if
+
+ return;
+} # ReturnMsg
+
+sub ReturnMessages($$) {
+ my ($userid, $sender) = @_;
+
+ my $statement = <<"END";
+select
+ subject,
+ timestamp
+from
+ email
+where
+ userid = '$userid' and
+ sender = '$sender'
+group by
+ timestamp desc
+END
+
+ my $sth = $DB->prepare($statement)
+ or DBError('ReturnMessages: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ReturnMessages: Unable to execute statement', $statement);
+
+ my @messages;
+
+ while (my @row = $sth->fetchrow_array) {
+ my $date = pop @row;
+ my $subject = pop @row;
+
+ push @messages, [$subject, $date];
+ } # while
+
+ $sth->finish;
+
+ return @messages;
+} # ReturnMessages
+
+# This subroutine returns an array of senders in reverse chronological
+# order based on time timestamp from the log table of when we returned
+# their message. The complication here is that a single sender may
+# send multiple times in a single day. So if spammer@foo.com sends
+# spam @ 1 second after midnight and then again at 2 Pm there will be
+# at least two records in the log table saying that we returned his
+# email. Getting records sorted by timestamp desc will have
+# spammer@foo.com listed twice. But we want him listed only once, as
+# the first entry in the returned array. Plus we may be called
+# repeatedly with different $start_at's. Therefore we need to process
+# the whole list of returns for today, eliminate duplicate entries for
+# a single sender then slice the resulting array.
+sub ReturnSenders($$$;$$) {
+ my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
+
+ $start_at ||= 0;
+
+ my $dateCond = '';
+
+ if ($date) {
+ my $sod = $date . ' 00:00:00';
+ my $eod = $date . ' 23:59:59';
+
+ $dateCond = "and timestamp > '$sod' and timestamp < '$eod'";
+ } # if
+
+ my $statement = <<"END";
+select
+ sender,
+ timestamp
+from
+ log
+where
+ userid = '$userid' and
+ type = '$type'
+ $dateCond
+order by
+ timestamp desc
+END
+
+ my $sth = $DB->prepare($statement)
+ or DBError('ReturnSenders: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('ReturnSenders: Unable to execute statement', $statement);
+
+ # Watch the distinction between senders (plural) and sender (singular)
+ my (%senders, %sendersByTimestamp);
+
+ # Run through the results and add to %senders by sender key. This
+ # results in a hash that has the sender in it and the first
+ # timestamp value. Since we already sorted timestamp desc by the
+ # above select statement, and we've narrowed it down to only log
+ # message that occurred for the given $date, we will have a hash
+ # containing 1 sender and the latest timestamp for the day.
+ while (my $senderRef = $sth->fetchrow_hashref) {
+ my %sender = %{$senderRef};
+
+ $senders{$sender{sender}} = $sender{timestamp}
+ unless $senders{$sender{sender}};
+ } # while
+
+ $sth->finish;
+
+ # Make a hash whose keys are the timestamp (so we can later sort on
+ # them).
+ while (my ($key, $value) = each %senders) {
+ $sendersByTimestamp{$value} = $key;
+ } # while
+
+ my @senders;
+
+ # Sort by timestamp desc and push on to the @senders array
+ push @senders, $sendersByTimestamp{$_}
+ for (sort { $b cmp $a } keys %sendersByTimestamp);
+
+ # Finally slice for the given range
+ my $end_at = $start_at + $nbr_emails - 1;
+
+ $end_at = (@senders - 1)
+ if $end_at > @senders;
+
+ return (@senders) [$start_at .. $end_at];
+} # ReturnSenders
+
+sub SaveMsg($$$) {
+ my ($sender, $subject, $data) = @_;
+
+ AddEmail($sender, $subject, $data);
+
+ return;
+} # SaveMsg
+
+sub SearchEmails($$) {
+ my ($userid, $searchfield) = @_;
+
+ my @emails;
+
+ my $statement =
+ "select sender, subject, timestamp from email where userid = '$userid' and (
+ sender like '%$searchfield%' or subject like '%$searchfield%')
+ order by timestamp desc";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('SearchEmails: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('SearchEmails: Unable to execute statement', $statement);
+
+ while (my @row = $sth->fetchrow_array) {
+ my $date = pop @row;
+ my $subject = pop @row;
+ my $sender = pop @row;
+
+ push @emails, [$sender, $subject, $date];
+ } # while
+
+ $sth->finish;
+
+ return @emails;
+} # SearchEmails
+
+sub SendMsg($$$$@) {
+ # SendMsg will send the message contained in $msgfile.
+ my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
+
+ my @lines;
+
+ # Open return message template file
+ open my $return_msg_file, '<', $msgfile
+ or die "Unable to open return msg file ($msgfile): $!\n";
+
+ # Read return message template file and print it to $msg_body
+ while (<$return_msg_file>) {
+ if (/\$userid/) {
+ # Replace userid
+ s/\$userid/$userid/;
+ } # if
+ if (/\$sender/) {
+ # Replace sender
+ s/\$sender/$sender/;
+ } #if
+
+ push @lines, $_;
+ } # while
+
+ close $return_msg_file;
+
+ # Create the message, and set up the mail headers:
+ my $msg = MIME::Entity->build(
+ From => "MAPS\@DeFaria.com",
+ To => $sender,
+ Subject => $subject,
+ Type => "text/html",
+ Data => \@lines
+ );
+
+ # Need to obtain the spam message here...
+ $msg->attach(
+ Type => "message",
+ Disposition => "attachment",
+ Data => \@spammsg
+ );
+
+ # Send it
+ open my $mail, '|-', '/usr/lib/sendmail -t -oi -oem'
+ or croak "SendMsg: Unable to open pipe to sendmail $!";
+
+ $msg->print(\*$mail);
+
+ close $mail;
+
+ return;
+} # SendMsg
+
+sub SetContext($) {
+ my ($to_user) = @_;
+
+ my $old_user = $userid;
+
+ if (UserExists($to_user)) {
+ $userid = $to_user;
+
+ GetUserOptions($userid);
+ return GetUserInfo $userid;
+ } else {
+ return 0;
+ } # if
+} # SetContext
+
+sub Space($) {
+ my ($userid) = @_;
+
+ my $total_space = 0;
+ my %msg_space;
+
+ my $statement = "select * from email where userid = '$userid'";
+ my $sth = $DB->prepare($statement)
+ or DBError('Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('Unable to execute statement', $statement);
+
+ while (my @row = $sth->fetchrow_array) {
+ last if !@row;
+
+ my $data = pop @row;
+ my $timestamp = pop @row;
+ my $subject = pop @row;
+ my $sender = pop @row;
+ my $user = pop @row;
+
+ my $msg_space =
+ length ($userid) +
+ length ($sender) +
+ length ($subject) +
+ length ($timestamp) +
+ length ($data);
+
+ $total_space += $msg_space;
+ $msg_space{$sender} += $msg_space;
+ } # while
+
+ $sth->finish;
+
+ return wantarray ? %msg_space : $total_space;
+} # Space
+
+sub UpdateList($$$$$$$) {
+ my ($userid, $type, $pattern, $domain, $comment, $hit_count, $sequence) = @_;
+
+ if (!$pattern || $pattern eq '') {
+ $pattern = 'NULL';
+ } else {
+ $pattern = "'" . quotemeta ($pattern) . "'";
+ } # if
+
+ if (!$domain || $domain eq '') {
+ $domain = 'NULL';
+ } else {
+ $domain = "'" . quotemeta ($domain) . "'";
+ } # if
+
+ if (!$comment || $comment eq '') {
+ $comment = 'NULL';
+ } else {
+ $comment = "'" . quotemeta ($comment) . "'";
+ } # if
+
+ if (!$hit_count || $hit_count eq '') {
+ $hit_count = 0;
+ #} else {
+ # TODO: Check if numeric
+ } # fi
+
+ my $statement =
+ 'update list set ' .
+ "pattern = $pattern, domain = $domain, comment = $comment, hit_count = $hit_count " .
+ "where userid = '$userid' and type = '$type' and sequence = $sequence";
+
+ $DB->do($statement)
+ or DBError('UpdateList: Unable to do statement', $statement);
+
+ return 0;
+} # UpdateList
+
+sub UpdateUser($$$$) {
+ my ($userid, $fullname, $email, $password) = @_;
+
+ return 1 if !UserExists($userid);
+
+ my $statement;
+
+ if (!defined $password || $password eq '') {
+ $statement = "update user set userid='$userid', name='$fullname', email='$email' where userid='$userid'";
+ } else {
+ $password = Encrypt $password, $userid;
+ $statement = "update user set userid='$userid', name='$fullname', email='$email', password='$password' where userid='$userid'";
+ } # if
+
+ $DB->do($statement)
+ or DBError('UpdateUser: Unable to do statement', $statement);
+
+ return 0;
+} # UpdateUser
+
+sub UpdateUserOptions ($@) {
+ my ($userid, %options) = @_;
+
+ return unless UserExists($userid);
+
+ for (keys(%options)) {
+ my $statement = "update useropts set value='$options{$_}' where userid='$userid' and name='$_'";
+
+ $DB->do($statement)
+ or DBError('UpdateUserOption: Unable to do statement', $statement);
+ } # for
+
+ return;
+} # UpdateUserOptions
+
+sub UserExists($) {
+ my ($userid) = @_;
+
+ return 0 unless $userid;
+
+ my $statement = "select userid, password from user where userid = '$userid'";
+
+ my $sth = $DB->prepare($statement)
+ or DBError('UserExists: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('UserExists: Unable to execute statement', $statement);
+
+ my @userdata = $sth->fetchrow_array;
+
+ $sth->finish;
+
+ return 0 if scalar(@userdata) == 0;
+
+ my $dbpassword = pop @userdata;
+ my $dbuserid = pop @userdata;
+
+ if ($dbuserid ne $userid) {
+ return 0;
+ } else {
+ return $dbpassword;
+ } # if
+} # UserExists
+
+sub Whitelist ($$;$$) {
+ # Whitelist will deliver the message.
+ my ($sender, $data, $sequence, $hit_count) = @_;
+
+ my $userid = GetContext;
+
+ # Dump message into a file
+ open my $message, '>', "/tmp/MAPSMessage.$$"
+ or Error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
+
+ print $message $data;
+
+ close $message;
+
+ # Now call MAPSDeliver
+ my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
+
+ unlink "/tmp/MAPSMessage.$$";
+
+ if ($status == 0) {
+ Logmsg("whitelist", $sender, "Delivered message");
+ } else {
+ Error("Unable to deliver message - is MAPSDeliver setgid? - $!");
+ } # if
+
+ RecordHit("white", $sequence, ++$hit_count) if $sequence;
+
+ return $status;
+} # Whitelist
+
+sub count($$) {
+ my ($table, $condition) = @_;
+
+ my $statement;
+
+ if ($condition) {
+ $statement = "select count(*) from $table where $condition";
+ } else {
+ $statement = "select count(*) from $table";
+ } # if
+
+ my $sth = $DB->prepare($statement)
+ or DBError('count: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('count: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many message there are
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ my $count;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ $count = 0
+ } else {
+ $count = $row[0];
+ } # unless
+
+ return $count
+} # count
+
+sub count_distinct($$$) {
+ my ($table, $column, $condition) = @_;
+
+ my $statement;
+
+ if ($condition) {
+ $statement = "select count(distinct $column) from $table where $condition";
+ } else {
+ $statement = "select count(distinct $column) from $table";
+ } # if
+
+ my $sth = $DB->prepare($statement)
+ or DBError('count: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or DBError('count: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many message there are
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ return 0;
+ } else {
+ return $row[0];
+ } # unless
+} # count_distinct
+
+sub countlog(;$) {
+ my ($additional_condition) = @_;
+
+ my $condition = "userid=\'$userid\' ";
+
+ $condition .= "and $additional_condition" if $additional_condition;
+
+ return count_distinct('log', 'sender', $condition);
+} # countlog
+
+1;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: MAPSFile.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: File manipulation routines for MAPS.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSFile;
+
+use strict;
+use vars qw (@ISA @EXPORT);
+
+use Fcntl ':flock'; # import LOCK_* constants
+
+use Exporter;
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Lock
+ Unlock
+);
+
+sub Lock($) {
+ my ($file) = @_;
+
+ flock($file, LOCK_EX);
+
+ # and, in case someone appended while we were waiting...
+ seek ($file, 0, 2);
+} # lock
+
+sub Unlock($) {
+ my ($file) = @_;
+
+ flock($file,LOCK_UN);
+} # unlock
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#################################################################################
+#
+# File: $RCSfile: MAPSLog.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: MAPS routines for logging.
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSLog;
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use MAPS;
+use MAPSUtil;
+
+use vars qw(@ISA @EXPORT);
+use Exporter;
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Debug
+ Error
+ GetStats
+ Info
+ Logmsg
+ getstats
+ @Types
+);
+
+our @Types = (
+ 'returned',
+ 'whitelist',
+ 'blacklist',
+ 'registered',
+ 'mailloop',
+ 'nulllist'
+);
+
+sub nbr_msgs($) {
+ my ($sender) = @_;
+
+ return FindEmail($sender);
+} # nbr_msgs
+
+sub GetStats(;$$) {
+ my ($nbr_days, $date) = @_;
+
+ $nbr_days ||= 1;
+ $date ||= Today2SQLDatetime();
+
+ my %dates;
+
+ while ($nbr_days > 0) {
+ my $ymd = substr $date, 0, 10;
+ my $sod = $ymd . ' 00:00:00';
+ my $eod = $ymd . ' 23:59:59';
+
+ my %stats;
+
+ for (@Types) {
+ my $condition = "type=\'$_\' and (timestamp > \'$sod\' and timestamp < \'$eod\')";
+
+ # Not sure why I need to qualify countlog
+ $stats{$_} = MAPS::countlog($condition);
+ } # for
+
+ $dates{$ymd} = \%stats;
+
+ $date = SubtractDays $date, 1;
+ $nbr_days--;
+ } # while
+
+ return %dates
+} # GetStats
+
+sub Logmsg($$$) {
+ my ($type, $sender, $msg) = @_;
+
+ # Todo: Why do I need to specify MAPS:: here?
+ MAPS::AddLog($type, $sender, $msg);
+
+ return;
+} # logmsg
+
+sub Debug($) {
+ my ($msg) = @_;
+
+ Logmsg('debug', '', $msg);
+
+ return;
+} # Debug
+
+sub Error($) {
+ my ($msg) = @_;
+
+ Logmsg('error', '', $msg);
+
+ return;
+} # Error
+
+sub Info($) {
+ my ($msg) = @_;
+
+ Logmsg('info', '', $msg);
+
+ return;
+} # info
+
+1;
--- /dev/null
+#!/usr/bin/perl
+################################################################################
+#
+# File: $RCSfile: MAPSUtil.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: MAPS Utilities
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSUtil;
+
+use strict;
+use warnings;
+
+use vars qw (@ISA @EXPORT);
+
+BEGIN {
+ $ENV{TZ}='America/Los_Angeles';
+} # BEGIN
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ FormatDate
+ FormatTime
+ SQLDatetime2UnixDatetime
+ SubtractDays
+ Today2SQLDatetime
+ UnixDatetime2SQLDatetime
+);
+
+sub Today2SQLDatetime;
+
+sub FormatDate {
+ my ($date) = @_;
+
+ return substr ($date, 5, 2) . '/' .
+ substr ($date, 8, 2) . '/' .
+ substr ($date, 0, 4);
+} # FormatDate
+
+sub FormatTime {
+ my ($time) = @_;
+
+ my $hours = substr $time, 0, 2;
+
+ $hours = substr $hours, 1, 1 if $hours < 10;
+
+ my $minutes = substr $time, 3, 2;
+ my $seconds = substr $time, 6, 2;
+ my $AmPm = $hours > 12 ? 'Pm' : 'Am';
+
+ $hours = $hours - 12 if $hours > 12;
+
+ return "$hours:$minutes:$seconds $AmPm";
+} # FormatTime
+
+sub SQLDatetime2UnixDatetime {
+ my ($sqldatetime) = @_;
+
+ my %months = (
+ '01' => 'Jan',
+ '02' => 'Feb',
+ '03' => 'Mar',
+ '04' => 'Apr',
+ '05' => 'May',
+ '06' => 'Jun',
+ '07' => 'Jul',
+ '08' => 'Aug',
+ '09' => 'Sep',
+ '10' => 'Oct',
+ '11' => 'Nov',
+ '12' => 'Dec',
+ );
+
+ my $year = substr $sqldatetime, 0, 4;
+ my $month = substr $sqldatetime, 5, 2;
+ my $day = substr $sqldatetime, 8, 2;
+ my $time = FormatTime substr $sqldatetime, 11;
+
+ return $months {$month} . " $day, $year \@ $time";
+} # SQLDatetime2UnixDatetime
+
+sub SubtractDays {
+ my ($timestamp,$nbr_of_days) = @_;
+
+ my @months = (
+ 31, # January
+ 28, # February
+ 31, # March
+ 30, # April
+ 31, # May
+ 30, # June
+ 31, # July
+ 31, # August
+ 30, # September
+ 31, # October
+ 30, # November
+ 31 # Descember
+ );
+
+ my $year = substr $timestamp, 0, 4;
+ my $month = substr $timestamp, 5, 2;
+ my $day = substr $timestamp, 8, 2;
+
+ # Convert to Julian
+ my $days = 0;
+ my $m = 1;
+
+ for (@months) {
+ last if $m >= $month;
+ $m++;
+ $days += $_;
+ } # for
+
+ # Subtract $nbr_of_days
+ $days += $day - $nbr_of_days;
+
+ # Compute $days_in_year
+ my $days_in_year;
+
+ # Adjust if crossing year boundary
+ if ($days <= 0) {
+ $year--;
+ $days_in_year = (($year % 4) == 0) ? 366 : 365;
+ $days = $days_in_year + $days;
+ } else {
+ $days_in_year = (($year % 4) == 0) ? 366 : 365;
+ } # if
+
+ # Convert back
+ $month = 0;
+
+ while ($days > 28) {
+ # If remaining days is less than the current month then last
+ last if ($days <= $months[$month]);
+
+ # Subtract off the number of days in this month
+ $days -= $months[$month++];
+ } # while
+
+ # Prefix month with 0 if necessary
+ $month++;
+ if ($month < 10) {
+ $month = '0' . $month;
+ } # if
+
+ # Prefix days with 0 if necessary
+ if ($days == 0) {
+ $days = '01';
+ } elsif ($days < 10) {
+ $days = '0' . $days;
+ } # if
+
+ return $year . '-' . $month . '-' . $days . substr $timestamp, 10;
+} # SubtractDays
+
+sub UnixDatetime2SQLDatetime($) {
+ my ($datetime) = @_;
+
+ my $orig_datetime = $datetime;
+ my %months = (
+ 'Jan' => '01',
+ 'Feb' => '02',
+ 'Mar' => '03',
+ 'Apr' => '04',
+ 'May' => '05',
+ 'Jun' => '06',
+ 'Jul' => '07',
+ 'Aug' => '08',
+ 'Sep' => '09',
+ 'Oct' => '10',
+ 'Nov' => '11',
+ 'Dec' => '12',
+ );
+
+ # Some mailers neglect to put the leading day of the week field in.
+ # Check for this and compensate.
+ my $dow = substr $datetime, 0, 3;
+
+ if ($dow ne 'Mon' &&
+ $dow ne 'Tue' &&
+ $dow ne 'Wed' &&
+ $dow ne 'Thu' &&
+ $dow ne 'Fri' &&
+ $dow ne 'Sat' &&
+ $dow ne 'Sun') {
+ $datetime = 'XXX, ' . $datetime;
+ } # if
+
+ # Some mailers have day before month. We need to correct this
+ my $day = substr $datetime, 5, 2;
+
+ if ($day =~ /\d /) {
+ $day = '0' . (substr $day, 0, 1);
+ $datetime = (substr $datetime, 0, 5) . $day . (substr $datetime, 6);
+ } # if
+
+ if ($day !~ /\d\d/) {
+ $day = substr $datetime, 8, 2;
+ } # if
+
+ # Check for 1 digit date
+ if ((substr $day, 0, 1) eq ' ') {
+ $day = '0' . (substr $day, 1, 1);
+ $datetime = (substr $datetime, 0, 8) . $day . (substr $datetime, 10);
+ } # if
+
+ my $year = substr $datetime, 20, 4;
+
+ if ($year !~ /\d\d\d\d/) {
+ $year = substr $datetime, 12, 4;
+ if ($year !~ /\d\d\d\d/) {
+ $year = substr $datetime, 12, 2;
+ } #if
+ } # if
+
+ # Check for 2 digit year. Argh!
+ if (length $year == 2 or (substr $year, 2, 1) eq ' ') {
+ $year = '20' . (substr $year, 0, 2);
+ $datetime = (substr $datetime, 0, 12) . '20' . (substr $datetime, 12);
+ } # if
+
+ my $month_name = substr $datetime, 4, 3;
+
+ if (!defined $months {$month_name}) {
+ $month_name = substr $datetime, 8, 3;
+ } # if
+ my $month = $months {$month_name};
+
+ my $time = substr $datetime, 11, 8;
+
+ if ($time !~ /\d\d:\d\d:\d\d/) {
+ $time = substr $datetime, 17, 8
+ } # if
+
+ if (!defined $year) {
+ print "WARNING: Year undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+ if (!defined $month) {
+ print "Month undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+ if (!defined $day) {
+ print "Day undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+ if (!defined $time) {
+ print "Time undefined for $orig_datetime\nReturning today's date\n";
+ return Today2SQLDatetime;
+ } # if
+
+ return "$year-$month-$day $time";
+} # UnixDatetime2SQLDatetime
+
+sub Today2SQLDatetime {
+ return UnixDatetime2SQLDatetime(scalar localtime);
+} # Today2SQLDatetime
+
+1;
--- /dev/null
+#################################################################################
+#
+# File: $RCSfile: MAPSWeb.pm,v $
+# Revision: $Revision: 1.1 $
+# Description: Routines for generating portions of MAPSWeb
+# Author: Andrew@DeFaria.com
+# Created: Fri Nov 29 14:17:21 2002
+# Modified: $Date: 2013/06/12 14:05:47 $
+# Language: perl
+#
+# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+#
+################################################################################
+package MAPSWeb;
+
+use strict;
+#use warnings;
+
+use MAPS;
+use MAPSLog;
+use MAPSUtil;
+
+use CGI qw (:standard *table start_Tr end_Tr start_div end_div);
+use vars qw (@ISA @EXPORT);
+
+use Exporter;
+
+@ISA = qw (Exporter);
+
+@EXPORT = qw (
+ Debug
+ DisplayError
+ Footing
+ Heading
+ NavigationBar
+);
+
+sub getquickstats($) {
+ my ($date) = @_;
+
+ my %dates = GetStats (1, $date);
+
+ for (@MAPSLog::Types) {
+ $dates{$date}{processed} += $dates{$date}{$_};
+ } # for
+
+ return %dates;
+} # getquickstats
+
+sub displayquickstats() {
+ # Quick stats are today only.
+ my $today = Today2SQLDatetime;
+ my $time = substr $today, 11;
+ my $date = substr $today, 0, 10;
+ my %dates = getquickstats $date;
+
+ print start_div {-class => 'quickstats'};
+ print h4 {-class => 'header',
+ -align => 'center'},
+ 'Today\'s Activity';
+ print p {-align => 'center'},
+ b ('as of ' . FormatTime ($time));
+ print start_table {
+ -align => 'center',
+ -border => 0,
+ -cellspacing => 0,
+ -cellpadding => 2};
+ print start_Tr {-align => 'right'};
+ print
+ td {-class => 'smalllabel',
+ -align => 'right'},
+ 'Processed';
+ print
+ td {-class => 'smallnumber',
+ -align => 'right'},
+ $dates{$date}{'processed'};
+ print
+ td {-class => 'smallnumber',
+ -align => 'right'},
+ 'n/a';
+ print end_Tr;
+
+ for (@MAPSLog::Types) {
+ print start_Tr {-align => 'right'};
+
+ my $value = $dates{$date}{$_};
+ my $percent;
+ if ($_ eq 'mailloop' || $_ eq 'registered') {
+ $percent = 'n/a';
+ } else {
+ $percent = $dates{$date}{processed} == 0 ?
+ 0 : $dates{$date}{$_} / $dates{$date}{processed} * 100;
+ $percent = sprintf '%5.1f%s', $percent, '%';
+ } # if
+ my $stat = $value == 0 ?
+ 0 : a {-href => "detail.cgi?type=$_;date=$date"}, $value;
+ print
+ td {-class => 'smalllabel'}, ucfirst ($_);
+ print
+ td {-class => 'smallnumber'}, $stat;
+ print
+ td {-class => 'smallnumber'}, $percent;
+ print end_Tr;
+ } # foreach
+ print end_table;
+ print end_div;
+
+ return;
+} # displayquickstats
+
+sub Footing(;$) {
+ my ($table_name) = @_;
+
+ # General footing (copyright). Note we calculate the current year
+ # so that the copyright automatically extends itself.
+ my $year = substr((scalar (localtime)), 20, 4);
+
+ print start_div {-class => "copyright"};
+ print "Copyright © 2001-$year - All rights reserved";
+ print br (
+ a ({-href => 'http://defaria.com'},
+ 'Andrew DeFaria'),
+ a ({-href => 'mailto:Andrew@DeFaria.com'},
+ '<Andrew@DeFaria.com>'));
+ print end_div;
+
+ print end_div; # This div ends "content" which was started in Heading
+ print "<script language='JavaScript1.2'>AdjustTableWidth (\"$table_name\");</script>"
+ if $table_name;
+ print end_html;
+
+ return;
+} # Footing
+
+sub Debug($) {
+ my ($msg) = @_;
+
+ print br, font ({ -class => 'error' }, 'DEBUG: '), $msg;
+
+ return;
+} # Debug
+
+sub DisplayError($) {
+ my ($errmsg) = @_;
+
+ print h3 ({-class => 'error',
+ -align => 'center'}, 'ERROR: ' . $errmsg);
+
+ Footing;
+
+ exit 1;
+} # DisplayError
+
+# This subroutine puts out the header for web pages. It is called by
+# various cgi scripts thus has a few parameters.
+sub Heading($$$$;$$@) {
+ my ($action, # One of getcookie, setcookie, unsetcookie
+ $userid, # User id (if setting a cookie)
+ $title, # Title string
+ $h1, # H1 header
+ $h2, # H2 header (optional)
+ $table_name, # Name of table in page, if any
+ @scripts) = @_; # Array of JavaScript scripts to include
+
+ my @java_scripts;
+ my $cookie;
+
+ # Since CheckAddress appears on all pages (well except for the login
+ # page) include it by default along with MAPSUtils.js
+ push @java_scripts, [
+ {-language => 'JavaScript1.2',
+ -src => '/maps/JavaScript/MAPSUtils.js'},
+ {-language => 'JavaScript1.2',
+ -src => '/maps/JavaScript/CheckAddress.js'}
+ ];
+
+ # Add on any additional JavaScripts that the caller wants. Note the
+ # odd single element array of hashes but that's what CGI requires!
+ # Build up scripts from array
+ for (@scripts) {
+ push @{$java_scripts[0]},
+ {-language => 'JavaScript1.2',
+ -src => "/maps/JavaScript/$_"}
+ } # foreach
+
+ # Since Heading is called from various scripts we sometimes need to
+ # set a cookie, other times delete a cookie but most times return the
+ # cookie.
+ if ($action eq 'getcookie') {
+ # Get userid from cookie
+ $userid = cookie ('MAPSUser');
+ } elsif ($action eq 'setcookie') {
+ $cookie = cookie (
+ -name => 'MAPSUser',
+ -value => $userid,
+ -expires => '+1y',
+ -path => '/maps'
+ );
+ } elsif ($action eq 'unsetcookie') {
+ $cookie = cookie (
+ -name => 'MAPSUser',
+ -value => '',
+ -expires => '-1d',
+ -path => '/maps'
+ );
+ } # if
+
+ print
+ header (-title => "MAPS: $title",
+ -cookie => $cookie);
+
+ if (defined $table_name) {
+ print
+ start_html (-title => "MAPS: $title",
+ -author => 'Andrew\@DeFaria.com',
+ -style => {-src => '/maps/css/MAPSStyle.css'},
+ -onResize => "AdjustTableWidth (\"$table_name\");",
+ -head => [
+ Link ({-rel => 'icon',
+ -href => '/maps/MAPS.png',
+ -type => 'image/png'}),
+ Link ({-rel => 'shortcut icon',
+ -href => '/maps/favicon.ico'})
+ ],
+ -script => @java_scripts);
+ } else {
+ print
+ start_html (-title => "MAPS: $title",
+ -author => 'Andrew\@DeFaria.com',
+ -style => {-src => '/maps/css/MAPSStyle.css'},
+ -head => [
+ Link ({-rel => 'icon',
+ -href => '/maps/MAPS.png',
+ -type => 'image/png'}),
+ Link ({-rel => 'shortcut icon',
+ -href => '/maps/favicon.ico'})],
+ -script => @java_scripts);
+ } # if
+
+ print start_div {class => 'heading'};
+ print h2 {-align => 'center',
+ -class => 'header'},
+ font ({-class => 'standout'}, 'MAPS'),
+ $h1;
+
+ if (defined $h2 && $h2 ne '') {
+ print h3 {-align => 'center',
+ -class => 'header'},
+ $h2;
+ } # if
+ print end_div;
+
+ # Start body content
+ print start_div {-class => 'content'};
+
+ return $userid
+} # Heading
+
+sub NavigationBar($) {
+ my ($userid) = @_;
+
+ print start_div {-id => 'leftbar'};
+
+ if (!defined $userid) {
+ print div ({-class => 'username'}, 'Welcome to MAPS');
+ print div ({-class => 'menu'},
+ (a {-href => '/maps/doc/'},
+ 'What is MAPS?<br>'),
+ (a {-href => '/maps/doc/SPAM.html'},
+ 'What is SPAM?<br>'),
+ (a {-href => '/maps/doc/Requirements.html'},
+ 'Requirements<br>'),
+ (a {-href => '/maps/SignupForm.html'},
+ 'Signup<br>'),
+ (a {-href => '/maps/doc/Using.html'},
+ 'Using MAPS<br>'),
+ (a {-href => '/maps/doc/'},
+ 'Help<br>'),
+ );
+ } else {
+ print div ({-class => 'username'}, 'Welcome '. ucfirst $userid);
+ print div ({-class => 'menu'},
+ (a {-href => '/maps/'},
+ 'MAPS Home<br>'),
+ (a {-href => '/maps/bin/stats.cgi'},
+ 'Statistics<br>'),
+ (a {-href => '/maps/bin/editprofile.cgi'},
+ 'Edit Profile<br>'),
+ (a {-href => '/maps/php/Reports.php'},
+ 'Reports<br>'),
+ (a {-href => '/maps/php/list.php?type=white'},
+ 'White List<br>'),
+ (a {-href => '/maps/php/list.php?type=black'},
+ 'Black List<br>'),
+ (a {-href => '/maps/php/list.php?type=null'},
+ 'Null List<br>'),
+ (a {-href => '/maps/doc/'},
+ 'Help<br>'),
+ (a {-href => '/maps/adm/'},
+ 'MAPS Admin<br>'),
+ (a {-href => '/maps/?logout=yes'},
+ 'Logout'),
+ );
+ print start_div {-class => 'search'};
+ print start_form {-method => 'get',
+ -action => '/maps/bin/search.cgi',
+ -name => 'search'};
+ print 'Search Sender/Subject',
+ textfield {-class => 'searchfield',
+ -id => 'searchfield',
+ -name => 'str',
+ -size => 20,
+ -maxlength => 255,
+ -value => '',
+ -onclick => "document.search.str.value = '';"};
+ print end_form;
+ print end_div;
+
+ displayquickstats;
+
+ print start_div {-class => 'search'};
+ print start_form {-method => 'post',
+ -action => 'javascript://',
+ -name => 'address',
+ -onsubmit => 'checkaddress(this);'};
+ print 'Check Email Address',
+ textfield {-class => 'searchfield',
+ -id => 'searchfield',
+ -name => 'email',
+ -size => 20,
+ -maxlength => 255,
+ -value => '',
+ -onclick => "document.address.email.value = '';"};
+ print end_form;
+ print end_div;
+ } # if
+
+ print end_div;
+} # NavigationBar
+
+1;
</table>
<br>
+ </form>
<div align=center>
<a href="/maps/bin/exportlist.cgi?type=<?php echo $type?>">
<input type=submit name=export value="Export List"></a>
<a href="/maps/bin/importlist.cgi?type=<?php echo $type?>">
<input type=submit name=import value="Import List"></a>
</div>
- </form>
<?php copyright (2001)?>
</body>
projects / clearscm.git / commitdiff